diff --git a/lib/git/conformance.sh b/lib/git/conformance.sh new file mode 100755 index 00000000..3de3c7e0 --- /dev/null +++ b/lib/git/conformance.sh @@ -0,0 +1,134 @@ +#!/usr/bin/env bash +# lib/git/conformance.sh — run sx-git test suites, emit scoreboard.json + scoreboard.md. + +set -uo pipefail +cd "$(git rev-parse --show-toplevel)" + +SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}" +if [ ! -x "$SX_SERVER" ]; then + SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe" +fi +if [ ! -x "$SX_SERVER" ]; then + echo "ERROR: sx_server.exe not found." >&2 + exit 1 +fi + +SUITES=(object ref dag worktree diff merge porcelain export import) + +OUT_JSON="lib/git/scoreboard.json" +OUT_MD="lib/git/scoreboard.md" + +run_suite() { + local suite=$1 + local file="lib/git/tests/${suite}.sx" + local TMP + TMP=$(mktemp) + cat > "$TMP" << EPOCHS +(epoch 1) +(load "spec/stdlib.sx") +(load "lib/r7rs.sx") +(load "lib/persist/event.sx") +(load "lib/persist/backend.sx") +(load "lib/persist/log.sx") +(load "lib/persist/kv.sx") +(load "lib/artdag/dag.sx") +(load "lib/datalog/tokenizer.sx") +(load "lib/datalog/parser.sx") +(load "lib/datalog/unify.sx") +(load "lib/datalog/db.sx") +(load "lib/datalog/builtins.sx") +(load "lib/datalog/aggregates.sx") +(load "lib/datalog/strata.sx") +(load "lib/datalog/eval.sx") +(load "lib/datalog/api.sx") +(load "lib/datalog/magic.sx") +(load "lib/git/object.sx") +(load "lib/git/ref.sx") +(load "lib/git/dag.sx") +(load "lib/git/worktree.sx") +(load "lib/git/diff.sx") +(load "lib/git/merge.sx") +(load "lib/git/porcelain.sx") +(load "lib/git/sha1.sx") +(load "lib/git/export.sx") +(load "lib/git/import.sx") +(epoch 2) +(eval "(define git-test-pass 0)") +(eval "(define git-test-fail 0)") +(eval "(define git-test-failures (list))") +(eval "(define git-test (fn (name got expected) (if (equal? got expected) (set! git-test-pass (+ git-test-pass 1)) (begin (set! git-test-fail (+ git-test-fail 1)) (set! git-test-failures (append git-test-failures (list (list name (inspect got) (inspect expected)))))))))") +(epoch 3) +(load "${file}") +(epoch 4) +(eval "(list git-test-pass git-test-fail)") +EPOCHS + + local OUTPUT + OUTPUT=$(timeout 300 "$SX_SERVER" < "$TMP" 2>/dev/null) + rm -f "$TMP" + + local LINE + LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 4 / {getline; print; exit}') + if [ -z "$LINE" ]; then + LINE=$(echo "$OUTPUT" | grep -E '^\(ok 4 \([0-9]+ [0-9]+\)\)' | tail -1 \ + | sed -E 's/^\(ok 4 //; s/\)$//') + fi + + local P F + P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/') + F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/') + P=${P:-0} + F=${F:-0} + echo "${P} ${F}" +} + +declare -A SUITE_PASS +declare -A SUITE_FAIL +TOTAL_PASS=0 +TOTAL_FAIL=0 + +echo "Running sx-git conformance suite..." >&2 +for s in "${SUITES[@]}"; do + read -r p f < <(run_suite "$s") + SUITE_PASS[$s]=$p + SUITE_FAIL[$s]=$f + TOTAL_PASS=$((TOTAL_PASS + p)) + TOTAL_FAIL=$((TOTAL_FAIL + f)) + printf " %-12s %d/%d\n" "$s" "$p" "$((p+f))" >&2 +done + +# scoreboard.json +{ + printf '{\n' + printf ' "suites": {\n' + first=1 + for s in "${SUITES[@]}"; do + if [ $first -eq 0 ]; then printf ',\n'; fi + printf ' "%s": {"pass": %d, "fail": %d}' "$s" "${SUITE_PASS[$s]}" "${SUITE_FAIL[$s]}" + first=0 + done + printf '\n },\n' + printf ' "total_pass": %d,\n' "$TOTAL_PASS" + printf ' "total_fail": %d,\n' "$TOTAL_FAIL" + printf ' "total": %d\n' "$((TOTAL_PASS + TOTAL_FAIL))" + printf '}\n' +} > "$OUT_JSON" + +# scoreboard.md +{ + printf '# sx-git Conformance Scoreboard\n\n' + printf '_Generated by `lib/git/conformance.sh`_\n\n' + printf '| Suite | Pass | Fail | Total |\n' + printf '|-------|-----:|-----:|------:|\n' + for s in "${SUITES[@]}"; do + p=${SUITE_PASS[$s]} + f=${SUITE_FAIL[$s]} + printf '| %s | %d | %d | %d |\n' "$s" "$p" "$f" "$((p+f))" + done + printf '| **Total** | **%d** | **%d** | **%d** |\n' "$TOTAL_PASS" "$TOTAL_FAIL" "$((TOTAL_PASS + TOTAL_FAIL))" +} > "$OUT_MD" + +echo "Wrote $OUT_JSON and $OUT_MD" >&2 +echo "Total: $TOTAL_PASS pass, $TOTAL_FAIL fail" >&2 + +[ "$TOTAL_FAIL" -eq 0 ] diff --git a/lib/git/dag.sx b/lib/git/dag.sx new file mode 100644 index 00000000..c3a3f75d --- /dev/null +++ b/lib/git/dag.sx @@ -0,0 +1,180 @@ +; lib/git/dag.sx — sx-git Phase 3: the commit DAG as queries. +; The workhorse walks (log, ancestry, reachability, merge-base) run SX-side +; over parent edges read straight from commit objects. The Datalog bridge +; exports those edges as (git-parent child parent) facts under a deliberately +; MINIMAL two-rule ancestor closure (every dl-query re-saturates the ruleset — +; keep it lean, walk SX-side; see lib/relations/engine.sx for the precedent). +; Requires: lib/git/object.sx; datalog stack only for the git/dag-db bridge. + +(define + git/parents + (fn + (repo cid) + (let + ((c (git/read repo cid))) + (if (git/commit? c) (git/commit-parents c) (list))))) + +; ---- DFS postorder over parent edges, visited-set threaded through ---- +; returns (seen acc); acc lists each commit AFTER all its parents. +(define + git/dag-post + (fn + (repo cid seen acc) + (if + (has-key? seen cid) + (list seen acc) + (let + ((res (git/dag-post-list repo (git/parents repo cid) (assoc seen cid true) acc))) + (list (first res) (append (nth res 1) (list cid))))))) + +(define + git/dag-post-list + (fn + (repo cids seen acc) + (if + (empty? cids) + (list seen acc) + (let + ((res (git/dag-post repo (first cids) seen acc))) + (git/dag-post-list + repo + (rest cids) + (first res) + (nth res 1)))))) + +; all commits reachable from cid, INCLUDING cid (parents-first order) +(define + git/reachable + (fn + (repo cid) + (nth (git/dag-post repo cid {} (list)) 1))) + +(define + git/reachable-all + (fn + (repo cids) + (nth (git/dag-post-list repo cids {} (list)) 1))) + +; ---- log: topological, children before parents (reverse DFS postorder) ---- +(define + git/log + (fn (repo head-cid) (reverse (git/reachable repo head-cid)))) + +(define + git/log-messages + (fn + (repo head-cid) + (map + (fn (c) (git/commit-message (git/read repo c))) + (git/log repo head-cid)))) + +; ---- ancestry ---- +; proper ancestors of cid (excludes cid itself unless reachable via a cycle, +; which a well-formed commit DAG never has) +(define + git/ancestors + (fn + (repo cid) + (nth + (git/dag-post-list repo (git/parents repo cid) {} (list)) + 1))) + +(define + git/dag-member? + (fn (x xs) (reduce (fn (acc y) (or acc (equal? x y))) false xs))) + +; reflexive, like `git merge-base --is-ancestor A B`: is a an ancestor of b? +(define + git/is-ancestor? + (fn + (repo a b) + (if (equal? a b) true (git/dag-member? a (git/ancestors repo b))))) + +; ---- merge-base (LCA) ---- +(define + git/dag-set + (fn (xs) (reduce (fn (acc x) (assoc acc x true)) {} xs))) + +(define + git/common-ancestors + (fn + (repo a b) + (let + ((sb (git/dag-set (git/reachable repo b)))) + (filter (fn (c) (has-key? sb c)) (git/reachable repo a))))) + +; all best common ancestors: common ancestors dominated by no other common +; ancestor (c is dominated when it is a proper ancestor of another common d) +(define + git/merge-bases + (fn + (repo a b) + (let + ((common (git/common-ancestors repo a b))) + (artdag/sort-strings + (filter + (fn + (c) + (not + (reduce + (fn + (acc d) + (or + acc + (and + (not (equal? c d)) + (git/dag-member? c (git/ancestors repo d))))) + false + common))) + common))))) + +(define + git/merge-base + (fn + (repo a b) + (let + ((bs (git/merge-bases repo a b))) + (if (empty? bs) nil (first bs))))) + +; ---- Datalog bridge: parent edges as facts, minimal ancestor closure ---- +(define + git/dag-rules + (quote + ((git-anc X Y <- (git-parent X Y)) + (git-anc X Y <- (git-parent X Z) (git-anc Z Y))))) + +(define + git/dag-facts + (fn + (repo heads) + (reduce + (fn + (acc c) + (append + acc + (map + (fn (p) (list (quote git-parent) c p)) + (git/parents repo c)))) + (list) + (git/reachable-all repo heads)))) + +(define + git/dag-db + (fn + (repo heads) + (dl-program-data (git/dag-facts repo heads) git/dag-rules))) + +(define + git/ancestors-dl + (fn + (db cid) + (artdag/sort-strings + (map + (fn (s) (get s :Y)) + (dl-query db (list (quote git-anc) cid (quote Y))))))) + +(define + git/is-ancestor-dl? + (fn + (db a b) + (> (len (dl-query db (list (quote git-anc) b a))) 0))) diff --git a/lib/git/diff.sx b/lib/git/diff.sx new file mode 100644 index 00000000..5c5183dc --- /dev/null +++ b/lib/git/diff.sx @@ -0,0 +1,427 @@ +; lib/git/diff.sx — sx-git Phase 5: structural tree diff + Myers line diff. +; Tree diff = files-diff over flattened trees (path -> blob cid). Blob diff = +; Myers O(ND) shortest edit script over lines, edit script ops +; {:op "eq"|"del"|"add" :line l}, rendered as unified hunks (context 3). +; Requires: lib/git/object.sx, lib/git/worktree.sx. + +; ---- lines <-> data ---- +(define + git/diff-take + (fn + (xs n) + (if + (or (= n 0) (empty? xs)) + (list) + (cons (first xs) (git/diff-take (rest xs) (- n 1)))))) + +(define + git/diff-lines + (fn + (s) + (let + ((parts (split s "\n"))) + (if + (and + (> (len parts) 0) + (equal? (nth parts (- (len parts) 1)) "")) + (git/diff-take parts (- (len parts) 1)) + parts)))) + +; index-keyed dict as an O(1) vector +(define + git/dvec + (fn + (xs) + (reduce + (fn (acc p) (assoc acc (str (first p)) (nth p 1))) + {} + (map-indexed (fn (i x) (list i x)) xs)))) +(define git/dget (fn (v i) (get v (str i)))) + +; ---- Myers forward pass ---- +; v: dict k(str) -> furthest x on diagonal k. Reads of k±1 always hit the +; previous round's parity, so in-round writes never corrupt the decision. +(define + git/myers-x + (fn + (v d k) + (if + (or + (= k (- 0 d)) + (and + (not (= k d)) + (< (git/dget v (- k 1)) (git/dget v (+ k 1))))) + (git/dget v (+ k 1)) + (+ (git/dget v (- k 1)) 1)))) + +(define + git/myers-snake + (fn + (av bv n m x y) + (if + (and (< x n) (< y m) (equal? (git/dget av x) (git/dget bv y))) + (git/myers-snake av bv n m (+ x 1) (+ y 1)) + (list x y)))) + +; one round d over k = -d, -d+2, ..., d; returns (v done?) +(define + git/myers-round + (fn + (av bv n m v d k) + (if + (> k d) + (list v false) + (let + ((sn (git/myers-snake av bv n m (git/myers-x v d k) (- (git/myers-x v d k) k)))) + (let + ((v2 (assoc v (str k) (first sn)))) + (if + (and (>= (first sn) n) (>= (nth sn 1) m)) + (list v2 true) + (git/myers-round av bv n m v2 d (+ k 2)))))))) + +; trace[d] = v entering round d; returns (trace D) +(define + git/myers-run + (fn + (av bv n m v d trace) + (let + ((trace2 (append trace (list v)))) + (let + ((res (git/myers-round av bv n m v d (- 0 d)))) + (if + (nth res 1) + (list trace2 d) + (git/myers-run av bv n m (first res) (+ d 1) trace2)))))) + +; ---- Myers backtrack: walk (n,m) back to (0,0), cons ops into forward order ---- +(define + git/myers-diag + (fn + (av x y px py ops) + (if + (and (> x px) (> y py)) + (git/myers-diag + av + (- x 1) + (- y 1) + px + py + (cons {:op "eq" :line (git/dget av (- x 1))} ops)) + (list x y ops)))) + +(define + git/myers-back + (fn + (av bv trace d x y ops) + (if + (< d 0) + ops + (let + ((v (nth trace d))) + (let + ((k (- x y))) + (let + ((pk (if (or (= k (- 0 d)) (and (not (= k d)) (< (git/dget v (- k 1)) (git/dget v (+ k 1))))) (+ k 1) (- k 1)))) + (let + ((px (git/dget v pk))) + (let + ((py (- px pk))) + (let + ((r (git/myers-diag av x y px py ops))) + (if + (> d 0) + (git/myers-back + av + bv + trace + (- d 1) + px + py + (if + (= (first r) px) + (cons {:op "add" :line (git/dget bv py)} (nth r 2)) + (cons {:op "del" :line (git/dget av px)} (nth r 2)))) + (nth r 2))))))))))) + +; ---- edit script over two strings ---- +(define + git/diff-script-lines + (fn + (al bl) + (let + ((rt (git/myers-run (git/dvec al) (git/dvec bl) (len al) (len bl) (assoc {} "1" 0) 0 (list)))) + (git/myers-back + (git/dvec al) + (git/dvec bl) + (first rt) + (nth rt 1) + (len al) + (len bl) + (list))))) + +(define + git/diff-script + (fn + (a-data b-data) + (git/diff-script-lines (git/diff-lines a-data) (git/diff-lines b-data)))) + +; reconstruction invariants: old = eq+del lines, new = eq+add lines +(define + git/diff-changes + (fn + (script) + (len (filter (fn (o) (not (equal? (get o :op) "eq"))) script)))) +(define + git/diff-old-lines + (fn + (script) + (map + (fn (o) (get o :line)) + (filter (fn (o) (not (equal? (get o :op) "add"))) script)))) + +; ---- unified rendering ---- +(define + git/diff-new-lines + (fn + (script) + (map + (fn (o) (get o :line)) + (filter (fn (o) (not (equal? (get o :op) "del"))) script)))) + +(define + git/diff-annotate + (fn + (script) + (nth + (reduce + (fn + (acc o) + (let + ((a (first acc)) + (b (nth acc 1)) + (out (nth acc 2))) + (cond + ((equal? (get o :op) "eq") + (list + (+ a 1) + (+ b 1) + (append out (list (merge o {:a a :b b}))))) + ((equal? (get o :op) "del") + (list + (+ a 1) + b + (append out (list (merge o {:a a :b b}))))) + (else + (list + a + (+ b 1) + (append out (list (merge o {:a a :b b})))))))) + (list 1 1 (list)) + script) + 2))) + +(define + git/diff-change-idxs + (fn + (script) + (map + (fn (p) (first p)) + (filter + (fn (p) (not (equal? (get (nth p 1) :op) "eq"))) + (map-indexed (fn (i o) (list i o)) script))))) + +(define + git/diff-merge-ranges + (fn + (ranges) + (reduce + (fn + (acc r) + (if + (empty? acc) + (list r) + (let + ((prev (nth acc (- (len acc) 1)))) + (if + (<= (first r) (+ (nth prev 1) 1)) + (append + (git/diff-take acc (- (len acc) 1)) + (list + (list + (first prev) + (max (nth prev 1) (nth r 1))))) + (append acc (list r)))))) + (list) + ranges))) + +(define + git/diff-hunk-ranges + (fn + (script ctx) + (git/diff-merge-ranges + (map + (fn + (i) + (list + (max 0 (- i ctx)) + (min (- (len script) 1) (+ i ctx)))) + (git/diff-change-idxs script))))) + +(define + git/diff-slice + (fn + (xs from to) + (map + (fn (p) (nth p 1)) + (filter + (fn (p) (and (>= (first p) from) (<= (first p) to))) + (map-indexed (fn (i x) (list i x)) xs))))) + +(define + git/diff-op-char + (fn + (op) + (cond ((equal? op "eq") " ") ((equal? op "del") "-") (else "+")))) + +(define + git/diff-hunk-render + (fn + (ops) + (let + ((acount (len (filter (fn (o) (not (equal? (get o :op) "add"))) ops))) + (bcount + (len (filter (fn (o) (not (equal? (get o :op) "del"))) ops)))) + (let + ((astart (if (= acount 0) (- (get (first ops) :a) 1) (get (first ops) :a))) + (bstart + (if + (= bcount 0) + (- (get (first ops) :b) 1) + (get (first ops) :b)))) + (str + "@@ -" + astart + "," + acount + " +" + bstart + "," + bcount + " @@\n" + (reduce + (fn + (acc o) + (str acc (git/diff-op-char (get o :op)) (get o :line) "\n")) + "" + ops)))))) + +; ---- object-level diffs ---- +(define + git/diff-unified + (fn + (a-data b-data) + (let + ((ann (git/diff-annotate (git/diff-script a-data b-data)))) + (reduce + (fn + (acc r) + (str + acc + (git/diff-hunk-render + (git/diff-slice ann (first r) (nth r 1))))) + "" + (git/diff-hunk-ranges ann 3))))) + +(define + git/blob-diff + (fn + (repo b1 b2) + (git/diff-script + (git/blob-data (git/read repo b1)) + (git/blob-data (git/read repo b2))))) + +(define + git/tree-diff + (fn + (repo t1 t2) + (git/files-diff (git/tree-flatten repo t1) (git/tree-flatten repo t2)))) + +; ---- whole-commit unified render: added, deleted, then modified paths ---- +(define + git/commit-diff + (fn + (repo c1 c2) + (git/tree-diff + repo + (git/commit-tree (git/read repo c1)) + (git/commit-tree (git/read repo c2))))) + +(define + git/diff-path-data + (fn + (repo flat path) + (if + (has-key? flat path) + (git/blob-data (git/read repo (get flat path))) + ""))) + +(define + git/commit-diff-unified + (fn + (repo c1 c2) + (let + ((f1 (git/tree-flatten repo (git/commit-tree (git/read repo c1)))) + (f2 (git/tree-flatten repo (git/commit-tree (git/read repo c2))))) + (let + ((d (git/files-diff f1 f2))) + (str + (reduce + (fn + (acc p) + (str + acc + "diff --sx a/" + p + " b/" + p + "\n--- /dev/null\n+++ b/" + p + "\n" + (git/diff-unified "" (git/diff-path-data repo f2 p)))) + "" + (get d :added)) + (reduce + (fn + (acc p) + (str + acc + "diff --sx a/" + p + " b/" + p + "\n--- a/" + p + "\n+++ /dev/null\n" + (git/diff-unified (git/diff-path-data repo f1 p) ""))) + "" + (get d :deleted)) + (reduce + (fn + (acc p) + (str + acc + "diff --sx a/" + p + " b/" + p + "\n--- a/" + p + "\n+++ b/" + p + "\n" + (git/diff-unified + (git/diff-path-data repo f1 p) + (git/diff-path-data repo f2 p)))) + "" + (get d :modified))))))) diff --git a/lib/git/export.sx b/lib/git/export.sx new file mode 100644 index 00000000..dae89647 --- /dev/null +++ b/lib/git/export.sx @@ -0,0 +1,225 @@ +; lib/git/export.sx — git-wire EXPORT ADAPTER (flagged extension). +; Converts native sx-git objects into byte-exact git loose-object payloads: +; " \0" with real git SHA-1 identity, golden-verified +; against git CLI output. This is an adapter at the edge — the base model +; stays native-CID (sx1:/sha256, typed extensible dicts). zlib/packfiles are +; host-side concerns and stay out of scope: the adapter emits type+bytes+sha1. +; Field mapping (commit/tag idents): :author/:email/:time/:tz with committer +; overrides :committer/:committer-email/:committer-time/:committer-tz; +; defaults email="@sx", time=0, tz="+0000". Messages get a trailing +; newline if missing. Extra native fields do NOT survive export (git wire +; has nowhere to put them) — that loss is the point of native-first. +; Requires: lib/git/object.sx, lib/git/sha1.sx, lib/artdag/dag.sx. + +(define git/export-nul (list->string (list (integer->char 0)))) + +; ---- tree entry details ---- +; raw tree bytes use "40000" for subtrees (no leading zero); files default +; to 100644 unless the entry carries an explicit :mode (e.g. "100755") +(define + git/export-mode + (fn + (e) + (if + (has-key? e :mode) + (get e :mode) + (if (equal? (get e :kind) "tree") "40000" "100644")))) + +; git sorts tree entries by name bytes with directories keyed as "name/" +(define + git/export-sortkey + (fn + (tree name) + (if + (equal? (git/entry-kind (git/tree-entry-for tree name)) "tree") + (str name "/") + name))) + +(define + git/export-ins + (fn + (tree sorted n) + (cond + ((empty? sorted) (list n)) + ((artdag/str " + (git/export-or (get obj :time) 0) + " " + (git/export-or (get obj :tz) "+0000"))))) + +(define + git/export-committer-ident + (fn + (obj) + (let + ((name (git/export-or (get obj :committer) (git/export-or (get obj :author) "sx")))) + (str + name + " <" + (git/export-or + (get obj :committer-email) + (git/export-or (get obj :email) (str name "@sx"))) + "> " + (git/export-or + (get obj :committer-time) + (git/export-or (get obj :time) 0)) + " " + (git/export-or + (get obj :committer-tz) + (git/export-or (get obj :tz) "+0000")))))) + +(define + git/export-message + (fn + (obj) + (let + ((m (git/export-or (get obj :message) ""))) + (let + ((n (string-length m))) + (if + (and + (> n 0) + (equal? (substring m (- n 1) n) "\n")) + m + (str m "\n")))))) + +; ---- object payloads ---- +(define + git/export-entry + (fn + (type body) + (let + ((full (str type " " (string-length body) git/export-nul body))) + {:type type :sha1 (git/sha1-hex full) :bytes full}))) + +(define + git/export-tree-body + (fn + (tree table) + (reduce + (fn + (acc name) + (let + ((e (git/tree-entry-for tree name))) + (str + acc + (git/export-mode e) + " " + name + git/export-nul + (git/hex->raw (get (get table (git/entry-cid e)) :sha1))))) + "" + (git/export-sort-names tree (git/tree-names tree))))) + +(define + git/export-commit-body + (fn + (obj table) + (str + "tree " + (get (get table (git/commit-tree obj)) :sha1) + "\n" + (reduce + (fn (acc p) (str acc "parent " (get (get table p) :sha1) "\n")) + "" + (git/commit-parents obj)) + "author " + (git/export-author-ident obj) + "\n" + "committer " + (git/export-committer-ident obj) + "\n" + "\n" + (git/export-message obj)))) + +(define + git/export-tag-body + (fn + (obj table) + (str + "object " + (get (get table (git/tag-target obj)) :sha1) + "\n" + "type " + (get (get table (git/tag-target obj)) :type) + "\n" + "tag " + (git/tag-name obj) + "\n" + "tagger " + (git/export-author-ident obj) + "\n" + "\n" + (git/export-message obj)))) + +; ---- recursive closure export: table cid -> {:type :bytes :sha1} ---- +(define + git/export-into + (fn + (repo cid table) + (if + (has-key? table cid) + table + (let + ((obj (git/read repo cid))) + (cond + ((git/blob? obj) + (assoc table cid (git/export-entry "blob" (git/blob-data obj)))) + ((git/tree? obj) + (let + ((t2 (reduce (fn (tb name) (git/export-into repo (git/entry-cid (git/tree-entry-for obj name)) tb)) table (git/tree-names obj)))) + (assoc + t2 + cid + (git/export-entry "tree" (git/export-tree-body obj t2))))) + ((git/commit? obj) + (let + ((t2 (git/export-into repo (git/commit-tree obj) (reduce (fn (tb p) (git/export-into repo p tb)) table (git/commit-parents obj))))) + (assoc + t2 + cid + (git/export-entry "commit" (git/export-commit-body obj t2))))) + ((git/tag? obj) + (let + ((t2 (git/export-into repo (git/tag-target obj) table))) + (assoc + t2 + cid + (git/export-entry "tag" (git/export-tag-body obj t2))))) + (else table)))))) + +(define + git/export-closure + (fn (repo cid) (git/export-into repo cid {}))) + +; export one object (with its dependencies): {:type :bytes :sha1} +(define git/export (fn (repo cid) (get (git/export-closure repo cid) cid))) + +(define git/export-sha (fn (repo cid) (get (git/export repo cid) :sha1))) + +; host-writable set: {:head :objects {sha1 -> {:type :bytes}}} +(define + git/export-set + (fn (repo cid) (let ((table (git/export-closure repo cid))) {:head (get (get table cid) :sha1) :objects (reduce (fn (acc c) (let ((e (get table c))) (assoc acc (get e :sha1) {:type (get e :type) :bytes (get e :bytes)}))) {} (keys table))}))) diff --git a/lib/git/import.sx b/lib/git/import.sx new file mode 100644 index 00000000..43fdaf4a --- /dev/null +++ b/lib/git/import.sx @@ -0,0 +1,244 @@ +; lib/git/import.sx — git-wire IMPORT (inverse of export.sx). +; Parses loose-object payloads " \0" back into native +; objects, bottom-up over an export-set-shaped table {sha1 -> {:bytes ...}}. +; Wire round-trip (bytes -> native -> bytes) is byte-exact: messages kept +; verbatim, non-default tree modes preserved as entry :mode, committer +; fields stored only when they differ from the author (so export's defaults +; regenerate identical bytes). Native cids of imported blobs/trees with +; default modes equal the originals'. +; Requires: lib/git/object.sx, lib/git/sha1.sx, lib/git/export.sx. + +; ---- scanning ---- +(define + git/import-index-of + (fn + (s ch i n) + (cond + ((>= i n) -1) + ((equal? (substring s i (+ i 1)) ch) i) + (else (git/import-index-of s ch (+ i 1) n))))) + +(define + git/import-find + (fn (s ch from) (git/import-index-of s ch from (string-length s)))) + +(define + git/import-rfind + (fn + (s ch i) + (cond + ((< i 0) -1) + ((equal? (substring s i (+ i 1)) ch) i) + (else (git/import-rfind s ch (- i 1)))))) + +(define + git/import-find2 + (fn + (s i n) + (cond + ((> (+ i 2) n) -1) + ((equal? (substring s i (+ i 2)) "\n\n") i) + (else (git/import-find2 s (+ i 1) n))))) + +(define + git/raw->hex-go + (fn + (raw i n acc) + (if + (>= i n) + acc + (git/raw->hex-go + raw + (+ i 1) + n + (str + acc + (git/sha1-byte-hex (char-code (substring raw i (+ i 1))))))))) + +(define + git/raw->hex + (fn (raw) (git/raw->hex-go raw 0 (string-length raw) ""))) + +; ---- payload header ---- +(define + git/import-payload + (fn + (bytes) + (let + ((sp (git/import-find bytes " " 0)) + (z (git/import-find bytes git/export-nul 0))) + {:type (substring bytes 0 sp) :body (substring bytes (+ z 1) (string-length bytes))}))) + +; ---- tree body: " \0<20 raw sha>" sequence ---- +(define + git/import-tree-entries + (fn + (body i n acc) + (if + (>= i n) + acc + (let + ((sp (git/import-find body " " i))) + (let + ((z (git/import-find body git/export-nul sp))) + (git/import-tree-entries + body + (+ z 21) + n + (append acc (list {:name (substring body (+ sp 1) z) :sha (git/raw->hex (substring body (+ z 1) (+ z 21))) :mode (substring body i sp)})))))))) + +; ---- ident: "name time tz" ---- +(define + git/import-ident + (fn + (line) + (let + ((lt (git/import-rfind line "<" (- (string-length line) 1))) + (gt (git/import-rfind line ">" (- (string-length line) 1)))) + (let + ((rest (substring line (+ gt 2) (string-length line)))) + (let ((sp (git/import-find rest " " 0))) {:name (substring line 0 (max 0 (- lt 1))) :tz (substring rest (+ sp 1) (string-length rest)) :email (substring line (+ lt 1) gt) :time (parse-int (substring rest 0 sp))}))))) + +; ---- commit / tag bodies ---- +(define + git/import-headers + (fn + (body) + (let + ((cut (git/import-find2 body 0 (string-length body)))) + {:message (substring body (+ cut 2) (string-length body)) :lines (split (substring body 0 cut) "\n")}))) + +(define + git/import-commit-parse + (fn + (body) + (let + ((h (git/import-headers body))) + (reduce + (fn + (acc line) + (cond + ((starts-with? line "tree ") + (assoc + acc + :tree (substring line 5 (string-length line)))) + ((starts-with? line "parent ") + (assoc + acc + :parents (append + (get acc :parents) + (list (substring line 7 (string-length line)))))) + ((starts-with? line "author ") + (assoc + acc + :author (git/import-ident + (substring line 7 (string-length line))))) + ((starts-with? line "committer ") + (assoc + acc + :committer (git/import-ident + (substring line 10 (string-length line))))) + (else acc))) + {:message (get h :message) :parents (list)} + (get h :lines))))) + +(define + git/import-tag-parse + (fn + (body) + (let + ((h (git/import-headers body))) + (reduce + (fn + (acc line) + (cond + ((starts-with? line "object ") + (assoc + acc + :object (substring line 7 (string-length line)))) + ((starts-with? line "tag ") + (assoc + acc + :tag (substring line 4 (string-length line)))) + ((starts-with? line "tagger ") + (assoc + acc + :tagger (git/import-ident + (substring line 7 (string-length line))))) + (else acc))) + {:message (get h :message)} + (get h :lines))))) + +; ident dict -> native commit meta fields +(define git/import-author-meta (fn (a) {:tz (get a :tz) :email (get a :email) :time (get a :time) :author (get a :name)})) + +(define + git/import-commit-meta + (fn + (p) + (let + ((a (get p :author)) (c (get p :committer))) + (merge + (merge (git/import-author-meta a) {:message (get p :message)}) + (if (or (equal? c nil) (= a c)) {} {:committer (get c :name) :committer-tz (get c :tz) :committer-email (get c :email) :committer-time (get c :time)}))))) + +; ---- bottom-up import over a sha->{:bytes} table; memo: sha -> native cid ---- +(define + git/import-sha + (fn + (repo objects sha memo) + (if + (has-key? memo sha) + memo + (let + ((p (git/import-payload (get (get objects sha) :bytes)))) + (cond + ((equal? (get p :type) "blob") + (assoc memo sha (git/write-blob repo (get p :body)))) + ((equal? (get p :type) "tree") + (let + ((res (reduce (fn (acc pe) (let ((m2 (git/import-sha repo objects (get pe :sha) (first acc)))) (list m2 (assoc (nth acc 1) (get pe :name) (let ((base {:kind (if (equal? (get pe :mode) "40000") "tree" "blob") :cid (get m2 (get pe :sha))})) (if (or (equal? (get pe :mode) "40000") (equal? (get pe :mode) "100644")) base (merge base {:mode (get pe :mode)}))))))) (list memo {}) (git/import-tree-entries (get p :body) 0 (string-length (get p :body)) (list))))) + (assoc + (first res) + sha + (git/write repo (git/tree (nth res 1)))))) + ((equal? (get p :type) "commit") + (let + ((cp (git/import-commit-parse (get p :body)))) + (let + ((m2 (git/import-sha repo objects (get cp :tree) (reduce (fn (mm ps) (git/import-sha repo objects ps mm)) memo (get cp :parents))))) + (assoc + m2 + sha + (git/write + repo + (git/commit + (get m2 (get cp :tree)) + (map (fn (ps) (get m2 ps)) (get cp :parents)) + (git/import-commit-meta cp))))))) + ((equal? (get p :type) "tag") + (let + ((tp (git/import-tag-parse (get p :body)))) + (let + ((m2 (git/import-sha repo objects (get tp :object) memo))) + (assoc + m2 + sha + (git/write + repo + (git/tag + (get m2 (get tp :object)) + (get tp :tag) + (merge + (git/import-author-meta (get tp :tagger)) + {:message (get tp :message)}))))))) + (else memo)))))) + +; import a {:head :objects} set; returns the native cid of the head object +(define + git/import-set + (fn + (repo set) + (get + (git/import-sha repo (get set :objects) (get set :head) {}) + (get set :head)))) diff --git a/lib/git/merge.sx b/lib/git/merge.sx new file mode 100644 index 00000000..0d9ff787 --- /dev/null +++ b/lib/git/merge.sx @@ -0,0 +1,224 @@ +; lib/git/merge.sx — sx-git Phase 6: 3-way merge. +; Textual diff3: regions (non-eq runs of the Myers script base->side) are +; clustered by strict base-interval overlap (same-point insertions from both +; sides also cluster); one-sided clusters apply cleanly, two-sided clusters +; take the shared result or emit diff3 conflict markers with the base section. +; Tree merge: per-path 3-way over flattened trees with blob-level textual +; auto-merge; delete/modify keeps the surviving side and flags the path. +; Commit merge: up-to-date / fast-forward detection, else merge via merge-base +; (empty base for unrelated histories). +; Requires: lib/git/object.sx, dag.sx, worktree.sx, diff.sx. + +(define + git/m3-concat + (fn (ls) (reduce (fn (acc l) (append acc l)) (list) ls))) + +; ---- regions: non-eq runs as {:s :e :repl} over base indices ---- +(define + git/m3-regions + (fn + (script) + (let + ((st (reduce (fn (acc o) (let ((op (get o :op))) (cond ((equal? op "eq") (if (get acc :open) {:repl (list) :s 0 :open false :out (append (get acc :out) (list {:repl (get acc :repl) :e (get acc :bi) :s (get acc :s)})) :bi (+ (get acc :bi) 1)} (assoc acc :bi (+ (get acc :bi) 1)))) ((equal? op "del") (if (get acc :open) (assoc acc :bi (+ (get acc :bi) 1)) (merge acc {:s (get acc :bi) :open true :bi (+ (get acc :bi) 1)}))) (else (if (get acc :open) (assoc acc :repl (append (get acc :repl) (list (get o :line)))) (merge acc {:repl (list (get o :line)) :s (get acc :bi) :open true})))))) {:repl (list) :s 0 :open false :out (list) :bi 0} script))) + (if + (get st :open) + (append (get st :out) (list {:repl (get st :repl) :e (get st :bi) :s (get st :s)})) + (get st :out))))) + +; ---- stable sort by :s (insert after equals: a-side stays before b-side) ---- +(define + git/m3-ins + (fn + (sorted r) + (cond + ((empty? sorted) (list r)) + ((< (get r :s) (get (first sorted) :s)) (cons r sorted)) + (else (cons (first sorted) (git/m3-ins (rest sorted) r)))))) + +(define + git/m3-sort + (fn (rs) (reduce (fn (acc r) (git/m3-ins acc r)) (list) rs))) + +; ---- clustering ---- +(define + git/m3-has-insert-at? + (fn + (ms p) + (reduce + (fn (acc m) (or acc (and (= (get m :s) p) (= (get m :e) p)))) + false + ms))) + +(define + git/m3-cluster-overlap? + (fn + (cur r) + (or + (< (get r :s) (get cur :ce)) + (and + (= (get r :s) (get r :e)) + (= (get r :s) (get cur :ce)) + (git/m3-has-insert-at? (get cur :members) (get r :s)))))) + +(define + git/m3-clusters + (fn + (regions) + (let + ((res (reduce (fn (acc r) (let ((cur (nth acc 1))) (if (equal? cur nil) (list (first acc) {:ce (get r :e) :members (list r) :cs (get r :s)}) (if (git/m3-cluster-overlap? cur r) (list (first acc) {:ce (max (get cur :ce) (get r :e)) :members (append (get cur :members) (list r)) :cs (get cur :cs)}) (list (append (first acc) (list cur)) {:ce (get r :e) :members (list r) :cs (get r :s)}))))) (list (list) nil) regions))) + (if + (equal? (nth res 1) nil) + (first res) + (append (first res) (list (nth res 1))))))) + +; ---- apply one side's regions across a base span ---- +(define + git/m3-bslice + (fn + (bv from to) + (if + (>= from to) + (list) + (cons (git/dget bv from) (git/m3-bslice bv (+ from 1) to))))) + +(define + git/m3-apply-side + (fn + (bv members side cs ce) + (let + ((res (reduce (fn (acc m) (list (get m :e) (append (nth acc 1) (append (git/m3-bslice bv (first acc) (get m :s)) (get m :repl))))) (list cs (list)) (filter (fn (m) (equal? (get m :side) side)) members)))) + (append (nth res 1) (git/m3-bslice bv (first res) ce))))) + +; ---- evaluate a cluster: clean lines or a conflict block ---- +(define + git/m3-eval-cluster + (fn + (bv cl) + (let + ((ms (get cl :members))) + (let + ((has-a (reduce (fn (acc m) (or acc (equal? (get m :side) "a"))) false ms)) + (has-b + (reduce + (fn (acc m) (or acc (equal? (get m :side) "b"))) + false + ms)) + (aout (git/m3-apply-side bv ms "a" (get cl :cs) (get cl :ce))) + (bout (git/m3-apply-side bv ms "b" (get cl :cs) (get cl :ce)))) + (cond + ((and has-a has-b (not (= aout bout))) {:conflict true :lines (git/m3-concat (list (list "<<<<<<< ours") aout (list "||||||| base") (git/m3-bslice bv (get cl :cs) (get cl :ce)) (list "=======") bout (list ">>>>>>> theirs")))}) + (has-a {:conflict false :lines aout}) + (else {:conflict false :lines bout})))))) + +; ---- diff3 over line lists ---- +(define + git/merge3-lines + (fn + (base-lines a-lines b-lines) + (let + ((bv (git/dvec base-lines))) + (let + ((all (git/m3-sort (append (map (fn (r) (assoc r :side "a")) (git/m3-regions (git/diff-script-lines base-lines a-lines))) (map (fn (r) (assoc r :side "b")) (git/m3-regions (git/diff-script-lines base-lines b-lines))))))) + (let + ((res (reduce (fn (acc cl) (let ((ev (git/m3-eval-cluster bv cl))) (list (get cl :ce) (append (nth acc 1) (append (git/m3-bslice bv (first acc) (get cl :cs)) (get ev :lines))) (+ (nth acc 2) (if (get ev :conflict) 1 0))))) (list 0 (list) 0) (git/m3-clusters all)))) + {:clean (= (nth res 2) 0) :conflicts (nth res 2) :lines (append (nth res 1) (git/m3-bslice bv (first res) (len base-lines)))}))))) + +(define + git/m3-unlines + (fn + (ls) + (if + (empty? ls) + "" + (str + (reduce (fn (acc l) (str acc "\n" l)) (first ls) (rest ls)) + "\n")))) + +; textual 3-way over strings: {:clean :conflicts :text} +(define + git/merge3-text + (fn + (base ours theirs) + (let + ((r (git/merge3-lines (git/diff-lines base) (git/diff-lines ours) (git/diff-lines theirs)))) + {:clean (get r :clean) :text (git/m3-unlines (get r :lines)) :conflicts (get r :conflicts)}))) + +; ---- tree building from path -> blob cid (no data reread) ---- +(define + git/tree-from-cids + (fn + (repo files) + (let + ((g (git/wt-group files))) + (let + ((with-blobs (reduce (fn (acc name) (assoc acc name (git/tree-entry "blob" (get (get g :files) name)))) {} (keys (get g :files))))) + (let + ((entries (reduce (fn (acc dir) (assoc acc dir (git/tree-entry "tree" (git/tree-from-cids repo (get (get g :dirs) dir))))) with-blobs (keys (get g :dirs))))) + (git/write repo (git/tree entries))))))) + +; ---- per-path 3-way tree merge: {:files path->cid :conflicts (paths)} ---- +(define + git/m3-union-paths + (fn (fa fb fc) (artdag/sort-strings (keys (merge (merge fa fb) fc))))) + +(define + git/merge-trees + (fn + (repo base-t a-t b-t) + (let + ((fb (if (equal? base-t nil) {} (git/tree-flatten repo base-t))) + (fa (git/tree-flatten repo a-t)) + (ft (git/tree-flatten repo b-t))) + (reduce + (fn + (acc path) + (let + ((bc (get fb path)) (ac (get fa path)) (tc (get ft path))) + (cond + ((equal? ac tc) + (if + (equal? ac nil) + acc + (assoc acc :files (assoc (get acc :files) path ac)))) + ((equal? bc ac) + (if + (equal? tc nil) + acc + (assoc acc :files (assoc (get acc :files) path tc)))) + ((equal? bc tc) + (if + (equal? ac nil) + acc + (assoc acc :files (assoc (get acc :files) path ac)))) + ((or (equal? ac nil) (equal? tc nil)) (merge acc {:conflicts (append (get acc :conflicts) (list path)) :files (assoc (get acc :files) path (if (equal? ac nil) tc ac))})) + (else + (let + ((m (git/merge3-text (if (equal? bc nil) "" (git/blob-data (git/read repo bc))) (git/blob-data (git/read repo ac)) (git/blob-data (git/read repo tc))))) + (let + ((cid (git/write-blob repo (get m :text)))) + (if + (get m :clean) + (assoc acc :files (assoc (get acc :files) path cid)) + (merge acc {:conflicts (append (get acc :conflicts) (list path)) :files (assoc (get acc :files) path cid)})))))))) + {:conflicts (list) :files {}} + (git/m3-union-paths fb fa ft))))) + +; ---- commit-level merge ---- +; can merging `theirs` into `ours` fast-forward? +(define git/ff? (fn (repo ours theirs) (git/is-ancestor? repo ours theirs))) + +(define + git/merge-commits + (fn + (repo ours theirs) + (cond + ((git/is-ancestor? repo theirs ours) {:cid ours :result "up-to-date"}) + ((git/is-ancestor? repo ours theirs) {:cid theirs :result "fast-forward"}) + (else + (let + ((mb (git/merge-base repo ours theirs))) + (let + ((mt (git/merge-trees repo (if (equal? mb nil) nil (git/commit-tree (git/read repo mb))) (git/commit-tree (git/read repo ours)) (git/commit-tree (git/read repo theirs))))) + (let + ((tc (git/tree-from-cids repo (get mt :files)))) + (if (empty? (get mt :conflicts)) {:conflicts (list) :tree tc :result "merged"} {:conflicts (get mt :conflicts) :tree tc :result "conflicts"})))))))) diff --git a/lib/git/object.sx b/lib/git/object.sx new file mode 100644 index 00000000..7822fee3 --- /dev/null +++ b/lib/git/object.sx @@ -0,0 +1,81 @@ +; lib/git/object.sx — sx-git Phase 1: blob/tree/commit/tag as content-addressed +; TYPED objects over the persist kv store. Identity = host digest of the +; canonical serialization (artdag/canon: sorted dict keys, escaped strings) — +; native CIDs, NOT git wire bytes. Objects are plain dicts: typed, extensible; +; unknown fields round-trip and participate in the CID. +; Requires: lib/persist/backend.sx, lib/persist/kv.sx, lib/artdag/dag.sx. + +; ---- canonical form + content id ---- +(define git/canon (fn (obj) (artdag/canon obj))) + +(define + git/cid + (fn (obj) (str "sx1:" (crypto-sha256 (artdag/canon obj))))) + +; ---- repo handle: a persist backend + key prefix (many repos per db) ---- +(define git/repo-named (fn (db name) {:prefix name :db db})) +(define git/repo (fn (db) (git/repo-named db "git"))) +(define git/repo-db (fn (repo) (get repo :db))) +(define git/obj-key (fn (repo cid) (str (get repo :prefix) "/obj/" cid))) + +; ---- constructors ---- +(define git/blob (fn (data) {:data data :type "blob"})) + +; entries: dict of name -> entry, entry = {:kind "blob"|"tree" :cid cid ...} +(define git/tree (fn (entries) {:type "tree" :entries entries})) +(define git/tree-entry (fn (kind cid) {:kind kind :cid cid})) + +; meta: open dict (:author :message :time ... anything); protected keys win +(define git/commit (fn (tree parents meta) (merge meta {:type "commit" :tree tree :parents parents}))) + +(define git/tag (fn (target name meta) (merge meta {:name name :type "tag" :target target}))) + +; ---- predicates / accessors ---- +(define git/object-type (fn (obj) (get obj :type))) +(define + git/blob? + (fn (obj) (and (dict? obj) (equal? (get obj :type) "blob")))) +(define + git/tree? + (fn (obj) (and (dict? obj) (equal? (get obj :type) "tree")))) +(define + git/commit? + (fn (obj) (and (dict? obj) (equal? (get obj :type) "commit")))) +(define + git/tag? + (fn (obj) (and (dict? obj) (equal? (get obj :type) "tag")))) + +(define git/blob-data (fn (obj) (get obj :data))) +(define git/tree-entries (fn (obj) (get obj :entries))) +(define git/tree-entry-for (fn (obj name) (get (get obj :entries) name))) +(define + git/tree-names + (fn (obj) (artdag/sort-strings (keys (get obj :entries))))) +(define git/entry-cid (fn (entry) (get entry :cid))) +(define git/entry-kind (fn (entry) (get entry :kind))) +(define git/commit-tree (fn (obj) (get obj :tree))) +(define git/commit-parents (fn (obj) (get obj :parents))) +(define git/commit-author (fn (obj) (get obj :author))) +(define git/commit-message (fn (obj) (get obj :message))) +(define git/tag-target (fn (obj) (get obj :target))) +(define git/tag-name (fn (obj) (get obj :name))) + +; ---- object store: write/read/has, keyed by cid ---- +(define + git/write + (fn + (repo obj) + (let + ((cid (git/cid obj))) + (begin (persist/kv-put (get repo :db) (git/obj-key repo cid) obj) cid)))) + +(define + git/read + (fn (repo cid) (persist/kv-get (get repo :db) (git/obj-key repo cid)))) + +(define + git/has? + (fn (repo cid) (persist/kv-has? (get repo :db) (git/obj-key repo cid)))) + +; convenience: write a blob straight from data +(define git/write-blob (fn (repo data) (git/write repo (git/blob data)))) diff --git a/lib/git/porcelain.sx b/lib/git/porcelain.sx new file mode 100644 index 00000000..acb90b2f --- /dev/null +++ b/lib/git/porcelain.sx @@ -0,0 +1,241 @@ +; lib/git/porcelain.sx — sx-git Phase 7: the user-facing verbs. +; init/add/commit/branch/checkout/tag/reset/merge/log/diff composed from +; object+ref+dag+worktree+diff+merge. Branch advances go through ref CAS. +; A conflicted merge parks the other head in /MERGE_HEAD (like git's +; MERGE_HEAD) and stages the marker tree; resolve with git/add! then +; git/merge-commit!, which writes the two-parent commit and clears it. +; Requires: all previous lib/git modules. + +(define + git/init! + (fn + (db name) + (let + ((repo (git/repo-named db name))) + (begin (git/head-set! repo "main") (git/index-init! repo nil) repo)))) + +; advance whatever HEAD points at: the branch via CAS, or the detached pin +(define + git/porc-advance! + (fn + (repo old new) + (let + ((target (git/head-target repo))) + (if + (equal? target nil) + (git/head-detach! repo new) + (git/ref-cas! repo target old new))))) + +; commit the index; parent = current HEAD (none on an unborn branch) +(define + git/commit! + (fn + (repo meta) + (let + ((tree (git/index-tree! repo))) + (let + ((parent (git/head repo))) + (let + ((cid (git/write repo (git/commit tree (if (equal? parent nil) (list) (list parent)) meta)))) + (begin + (git/porc-advance! repo parent cid) + (git/index-write! repo {:base tree :staged {}}) + cid)))))) + +; branch at HEAD (create-only) +(define + git/branch! + (fn (repo name) (git/branch-create! repo name (git/head repo)))) + +; switch HEAD + index to a branch; returns the materialized files dict +(define + git/checkout! + (fn + (repo branch) + (let + ((cid (git/branch-get repo branch))) + (begin + (git/head-set! repo branch) + (git/index-init! repo cid) + (if (equal? cid nil) {} (git/commit-files repo cid)))))) + +(define + git/checkout-detached! + (fn + (repo cid) + (begin + (git/head-detach! repo cid) + (git/index-init! repo cid) + (git/commit-files repo cid)))) + +; annotated tag: tag OBJECT at HEAD, ref points at the tag object +(define + git/tag! + (fn + (repo name meta) + (let + ((cid (git/write repo (git/tag (git/head repo) name meta)))) + (begin (git/tag-set! repo name cid) cid)))) + +(define + git/tag-lightweight! + (fn + (repo name) + (begin (git/tag-set! repo name (git/head repo)) (git/head repo)))) + +; reset current branch to cid; "soft" keeps the index, "mixed" resets it +(define + git/reset! + (fn + (repo cid mode) + (begin + (git/porc-advance! repo (git/head repo) cid) + (when (equal? mode "mixed") (git/index-init! repo cid)) + cid))) + +; ---- merge a branch into HEAD ---- +(define + git/merge-head-key + (fn (repo) (str (get repo :prefix) "/MERGE_HEAD"))) +(define + git/merge-in-progress? + (fn + (repo) + (not + (equal? (persist/kv-get (get repo :db) (git/merge-head-key repo)) nil)))) + +(define + git/merge! + (fn + (repo branch meta) + (let + ((ours (git/head repo)) (theirs (git/branch-get repo branch))) + (let + ((m (git/merge-commits repo ours theirs))) + (cond + ((equal? (get m :result) "up-to-date") m) + ((equal? (get m :result) "fast-forward") + (begin + (git/porc-advance! repo ours theirs) + (git/index-init! repo theirs) + m)) + ((equal? (get m :result) "merged") + (let + ((cid (git/write repo (git/commit (get m :tree) (list ours theirs) meta)))) + (begin + (git/porc-advance! repo ours cid) + (git/index-write! repo {:base (get m :tree) :staged {}}) + {:conflicts (list) :cid cid :result "merged"}))) + (else + (begin + (persist/kv-put + (get repo :db) + (git/merge-head-key repo) + theirs) + (git/index-write! repo {:base (get m :tree) :staged {}}) + m))))))) + +; conclude a conflicted merge: commit the (resolved) index with two parents +(define + git/merge-commit! + (fn + (repo meta) + (let + ((theirs (persist/kv-get (get repo :db) (git/merge-head-key repo)))) + (if + (equal? theirs nil) + {:error "no merge in progress"} + (let + ((tree (git/index-tree! repo))) + (let + ((parent (git/head repo))) + (let + ((cid (git/write repo (git/commit tree (list parent theirs) meta)))) + (begin + (git/porc-advance! repo parent cid) + (git/index-write! repo {:base tree :staged {}}) + (persist/kv-delete (get repo :db) (git/merge-head-key repo)) + cid)))))))) + +; ---- porcelain diff/log ---- +(define + git/log-branch + (fn (repo branch) (git/log repo (git/branch-get repo branch)))) + +; unified diff across two path->data dicts (added, deleted, then modified) +(define + git/diff-files-unified + (fn + (fa fb) + (let + ((d (git/files-diff (git/files-cids fa) (git/files-cids fb)))) + (str + (reduce + (fn + (acc p) + (str + acc + "diff --sx a/" + p + " b/" + p + "\n--- /dev/null\n+++ b/" + p + "\n" + (git/diff-unified "" (get fb p)))) + "" + (get d :added)) + (reduce + (fn + (acc p) + (str + acc + "diff --sx a/" + p + " b/" + p + "\n--- a/" + p + "\n+++ /dev/null\n" + (git/diff-unified (get fa p) ""))) + "" + (get d :deleted)) + (reduce + (fn + (acc p) + (str + acc + "diff --sx a/" + p + " b/" + p + "\n--- a/" + p + "\n+++ b/" + p + "\n" + (git/diff-unified (get fa p) (get fb p)))) + "" + (get d :modified)))))) + +(define + git/porc-head-files + (fn + (repo) + (let + ((h (git/head repo))) + (if (equal? h nil) {} (git/commit-files repo h))))) + +; staged: HEAD vs index; unstaged: index vs the caller's worktree value +(define + git/diff-staged + (fn + (repo) + (git/diff-files-unified + (git/porc-head-files repo) + (git/index-files repo)))) +(define + git/diff-unstaged + (fn + (repo worktree-files) + (git/diff-files-unified (git/index-files repo) worktree-files))) diff --git a/lib/git/ref.sx b/lib/git/ref.sx new file mode 100644 index 00000000..af9105e6 --- /dev/null +++ b/lib/git/ref.sx @@ -0,0 +1,197 @@ +; lib/git/ref.sx — sx-git Phase 2: refs as name -> cid over persist kv. +; A ref value is {:cid cid} (direct) or {:symref name} (symbolic). Atomic +; update = persist/kv-cas (old-value expect); create-only = kv-put-new. +; Every direct-ref move is recorded in an append-only reflog stream +; (persist log facet), one stream per ref name. +; Requires: lib/git/object.sx (repo handle), lib/persist/kv.sx, log.sx. + +(define git/ref-key (fn (repo name) (str (get repo :prefix) "/ref/" name))) +(define + git/reflog-stream + (fn (repo name) (str (get repo :prefix) "/reflog/" name))) + +(define + git/reflog-record! + (fn + (repo name old new) + (persist/append + (get repo :db) + (git/reflog-stream repo name) + "ref-update" + 0 + {:new new :old old}))) + +; ---- raw ref values ---- +(define + git/ref-read + (fn (repo name) (persist/kv-get (get repo :db) (git/ref-key repo name)))) +(define git/symref? (fn (v) (and (dict? v) (has-key? v :symref)))) + +; direct cid or nil — does NOT follow symrefs +(define + git/ref-get + (fn + (repo name) + (let ((v (git/ref-read repo name))) (if (dict? v) (get v :cid) nil)))) + +; ---- writes ---- +(define + git/ref-set! + (fn + (repo name cid) + (let + ((old (git/ref-get repo name))) + (begin + (persist/kv-put (get repo :db) (git/ref-key repo name) {:cid cid}) + (git/reflog-record! repo name old cid) + cid)))) + +(define + git/symref-set! + (fn + (repo name target) + (begin + (persist/kv-put (get repo :db) (git/ref-key repo name) {:symref target}) + target))) + +(define + git/ref-delete! + (fn + (repo name) + (persist/kv-delete (get repo :db) (git/ref-key repo name)))) + +; ---- resolution (symref chains, bounded) ---- +(define + git/ref-resolve-n + (fn + (repo name depth) + (if + (<= depth 0) + nil + (let + ((v (git/ref-read repo name))) + (cond + ((git/symref? v) + (git/ref-resolve-n repo (get v :symref) (- depth 1))) + ((dict? v) (get v :cid)) + (else nil)))))) + +(define + git/ref-resolve + (fn (repo name) (git/ref-resolve-n repo name 10))) + +; ---- atomic update: expected old cid (nil = must not exist) ---- +(define + git/ref-cas! + (fn + (repo name expected new) + (let + ((res (persist/kv-cas (get repo :db) (git/ref-key repo name) (if (equal? expected nil) nil {:cid expected}) {:cid new}))) + (if + (and (dict? res) (has-key? res :conflict)) + {:actual (if (dict? (get res :actual)) (get (get res :actual) :cid) nil) :conflict true} + (begin (git/reflog-record! repo name expected new) new))))) + +; ---- listing ---- +(define + git/ref-names + (fn + (repo) + (let + ((pfx (str (get repo :prefix) "/ref/"))) + (artdag/sort-strings + (map + (fn (k) (substring k (string-length pfx) (string-length k))) + (filter + (fn (k) (starts-with? k pfx)) + (persist/kv-keys (get repo :db)))))))) + +(define + git/refs-under + (fn + (repo group) + (map + (fn (n) (substring n (string-length group) (string-length n))) + (filter (fn (n) (starts-with? n group)) (git/ref-names repo))))) + +; ---- branches ---- +(define git/branch-ref (fn (name) (str "heads/" name))) + +(define + git/branch-set! + (fn (repo name cid) (git/ref-set! repo (git/branch-ref name) cid))) +(define + git/branch-get + (fn (repo name) (git/ref-get repo (git/branch-ref name)))) +(define + git/branch-cas! + (fn + (repo name expected new) + (git/ref-cas! repo (git/branch-ref name) expected new))) +(define + git/branch-delete! + (fn (repo name) (git/ref-delete! repo (git/branch-ref name)))) +(define git/branches (fn (repo) (git/refs-under repo "heads/"))) + +; create-only: conflict if the branch already exists +(define + git/branch-create! + (fn + (repo name cid) + (let + ((res (persist/kv-put-new (get repo :db) (git/ref-key repo (git/branch-ref name)) {:cid cid}))) + (if + (and (dict? res) (has-key? res :conflict)) + {:actual (get (get res :actual) :cid) :conflict true} + (begin (git/reflog-record! repo (git/branch-ref name) nil cid) cid))))) + +; ---- lightweight tag refs (annotated tag objects live in the object store) ---- +(define git/tag-refname (fn (name) (str "tags/" name))) +(define + git/tag-set! + (fn (repo name cid) (git/ref-set! repo (git/tag-refname name) cid))) +(define + git/tag-get + (fn (repo name) (git/ref-get repo (git/tag-refname name)))) +(define git/tag-names (fn (repo) (git/refs-under repo "tags/"))) + +; ---- HEAD ---- +(define + git/head-set! + (fn (repo branch) (git/symref-set! repo "HEAD" (git/branch-ref branch)))) + +(define + git/head-detach! + (fn + (repo cid) + (begin + (persist/kv-put (get repo :db) (git/ref-key repo "HEAD") {:cid cid}) + cid))) + +(define git/head (fn (repo) (git/ref-resolve repo "HEAD"))) + +; branch ref name HEAD points at, or nil when detached/unset +(define + git/head-target + (fn + (repo) + (let + ((v (git/ref-read repo "HEAD"))) + (if (git/symref? v) (get v :symref) nil)))) + +(define + git/detached? + (fn + (repo) + (let + ((v (git/ref-read repo "HEAD"))) + (and (dict? v) (has-key? v :cid))))) + +; ---- reflog: oldest-first list of {:old :new} ---- +(define + git/reflog + (fn + (repo name) + (map + (fn (e) (persist/event-data e)) + (persist/read (get repo :db) (git/reflog-stream repo name))))) diff --git a/lib/git/scoreboard.json b/lib/git/scoreboard.json new file mode 100644 index 00000000..7d2ddc5c --- /dev/null +++ b/lib/git/scoreboard.json @@ -0,0 +1,16 @@ +{ + "suites": { + "object": {"pass": 38, "fail": 0}, + "ref": {"pass": 38, "fail": 0}, + "dag": {"pass": 30, "fail": 0}, + "worktree": {"pass": 26, "fail": 0}, + "diff": {"pass": 27, "fail": 0}, + "merge": {"pass": 28, "fail": 0}, + "porcelain": {"pass": 40, "fail": 0}, + "export": {"pass": 25, "fail": 0}, + "import": {"pass": 15, "fail": 0} + }, + "total_pass": 267, + "total_fail": 0, + "total": 267 +} diff --git a/lib/git/scoreboard.md b/lib/git/scoreboard.md new file mode 100644 index 00000000..4e4491bd --- /dev/null +++ b/lib/git/scoreboard.md @@ -0,0 +1,16 @@ +# sx-git Conformance Scoreboard + +_Generated by `lib/git/conformance.sh`_ + +| Suite | Pass | Fail | Total | +|-------|-----:|-----:|------:| +| object | 38 | 0 | 38 | +| ref | 38 | 0 | 38 | +| dag | 30 | 0 | 30 | +| worktree | 26 | 0 | 26 | +| diff | 27 | 0 | 27 | +| merge | 28 | 0 | 28 | +| porcelain | 40 | 0 | 40 | +| export | 25 | 0 | 25 | +| import | 15 | 0 | 15 | +| **Total** | **267** | **0** | **267** | diff --git a/lib/git/sha1.sx b/lib/git/sha1.sx new file mode 100644 index 00000000..78cc7917 --- /dev/null +++ b/lib/git/sha1.sx @@ -0,0 +1,299 @@ +; lib/git/sha1.sx — SHA-1 in pure SX (host bitwise prims, no deps). +; Exists ONLY for the git-wire export adapter: native sx-git identity stays +; sx1:/sha256 (object.sx); SHA-1 is what the exported byte format demands. +; Strings are treated as byte strings (char-code on 1-byte substrings). + +(define git/sha1-mask 4294967295) +(define git/u32 (fn (x) (bitwise-and x git/sha1-mask))) + +(define + git/rotl + (fn + (x n) + (git/u32 + (bitwise-or + (arithmetic-shift x n) + (arithmetic-shift x (- n 32)))))) + +; ---- byte plumbing ---- +(define + git/sha1-take + (fn + (xs n) + (if + (or (= n 0) (empty? xs)) + (list) + (cons (first xs) (git/sha1-take (rest xs) (- n 1)))))) + +(define + git/sha1-drop + (fn + (xs n) + (if + (or (= n 0) (empty? xs)) + xs + (git/sha1-drop (rest xs) (- n 1))))) + +(define + git/sha1-sb + (fn + (s i n acc) + (if + (>= i n) + (reverse acc) + (git/sha1-sb + s + (+ i 1) + n + (cons (char-code (substring s i (+ i 1))) acc))))) + +(define + git/sha1-str-bytes + (fn (s) (git/sha1-sb s 0 (string-length s) (list)))) + +(define + git/sha1-zeros + (fn + (k) + (if + (= k 0) + (list) + (cons 0 (git/sha1-zeros (- k 1)))))) + +(define + git/sha1-be8 + (fn + (v) + (map + (fn + (sh) + (bitwise-and (arithmetic-shift v (- 0 sh)) 255)) + (list + 56 + 48 + 40 + 32 + 24 + 16 + 8 + 0)))) + +; append 0x80, zero-pad to 56 mod 64, then the 64-bit big-endian bit length +(define + git/sha1-pad + (fn + (bytes) + (let + ((n (len bytes))) + (let + ((zeros (remainder (+ (- 56 (remainder (+ n 1) 64)) 64) 64))) + (append + bytes + (append + (cons 128 (git/sha1-zeros zeros)) + (git/sha1-be8 (* n 8)))))))) + +; ---- message schedule: w as an index-keyed dict ---- +(define + git/sha1-w-init-go + (fn + (bs j w) + (if + (= j 16) + w + (git/sha1-w-init-go + (git/sha1-drop bs 4) + (+ j 1) + (assoc + w + (str j) + (bitwise-or + (arithmetic-shift (nth bs 0) 24) + (bitwise-or + (arithmetic-shift (nth bs 1) 16) + (bitwise-or + (arithmetic-shift (nth bs 2) 8) + (nth bs 3))))))))) + +(define + git/sha1-w-expand + (fn + (w t) + (if + (= t 80) + w + (git/sha1-w-expand + (assoc + w + (str t) + (git/rotl + (bitwise-xor + (bitwise-xor + (get w (str (- t 3))) + (get w (str (- t 8)))) + (bitwise-xor + (get w (str (- t 14))) + (get w (str (- t 16))))) + 1)) + (+ t 1))))) + +; ---- rounds ---- +(define + git/sha1-f + (fn + (t b c d) + (cond + ((< t 20) + (bitwise-or + (bitwise-and b c) + (bitwise-and (bitwise-and (bitwise-not b) git/sha1-mask) d))) + ((< t 40) (bitwise-xor (bitwise-xor b c) d)) + ((< t 60) + (bitwise-or + (bitwise-or (bitwise-and b c) (bitwise-and b d)) + (bitwise-and c d))) + (else (bitwise-xor (bitwise-xor b c) d))))) + +(define + git/sha1-k + (fn + (t) + (cond + ((< t 20) 1518500249) + ((< t 40) 1859775393) + ((< t 60) 2400959708) + (else 3395469782)))) + +(define + git/sha1-rounds + (fn + (w t a b c d e) + (if + (= t 80) + (list a b c d e) + (git/sha1-rounds + w + (+ t 1) + (git/u32 + (+ + (+ + (+ (+ (git/rotl a 5) (git/sha1-f t b c d)) e) + (git/sha1-k t)) + (get w (str t)))) + a + (git/rotl b 30) + c + d)))) + +(define + git/sha1-blocks + (fn + (bs hs) + (if + (empty? bs) + hs + (let + ((w (git/sha1-w-expand (git/sha1-w-init-go (git/sha1-take bs 64) 0 {}) 16))) + (let + ((r (git/sha1-rounds w 0 (nth hs 0) (nth hs 1) (nth hs 2) (nth hs 3) (nth hs 4)))) + (git/sha1-blocks + (git/sha1-drop bs 64) + (list + (git/u32 (+ (nth hs 0) (nth r 0))) + (git/u32 (+ (nth hs 1) (nth r 1))) + (git/u32 (+ (nth hs 2) (nth r 2))) + (git/u32 (+ (nth hs 3) (nth r 3))) + (git/u32 (+ (nth hs 4) (nth r 4)))))))))) + +(define + git/sha1-words + (fn + (s) + (git/sha1-blocks + (git/sha1-pad (git/sha1-str-bytes s)) + (list 1732584193 4023233417 2562383102 271733878 3285377520)))) + +; ---- digest forms ---- +(define + git/sha1-word-bytes + (fn + (v) + (list + (bitwise-and (arithmetic-shift v -24) 255) + (bitwise-and (arithmetic-shift v -16) 255) + (bitwise-and (arithmetic-shift v -8) 255) + (bitwise-and v 255)))) + +(define + git/sha1-digest-bytes + (fn + (s) + (reduce + (fn (acc v) (append acc (git/sha1-word-bytes v))) + (list) + (git/sha1-words s)))) + +(define git/sha1-hexd "0123456789abcdef") +(define + git/sha1-byte-hex + (fn + (b) + (str + (substring + git/sha1-hexd + (quotient b 16) + (+ (quotient b 16) 1)) + (substring + git/sha1-hexd + (remainder b 16) + (+ (remainder b 16) 1))))) + +(define + git/sha1-hex + (fn + (s) + (reduce + (fn (acc b) (str acc (git/sha1-byte-hex b))) + "" + (git/sha1-digest-bytes s)))) + +(define + git/sha1-raw + (fn + (s) + (list->string + (map (fn (b) (integer->char b)) (git/sha1-digest-bytes s))))) + +; hex string -> raw bytes (tree entries embed 20 raw sha bytes) +(define + git/hex-digit-val + (fn + (c) + (let + ((v (char-code c))) + (if (< v 58) (- v 48) (- v 87))))) + +(define + git/hex->raw-go + (fn + (h i n acc) + (if + (>= i n) + (list->string (reverse acc)) + (git/hex->raw-go + h + (+ i 2) + n + (cons + (integer->char + (+ + (* + 16 + (git/hex-digit-val (substring h i (+ i 1)))) + (git/hex-digit-val + (substring h (+ i 1) (+ i 2))))) + acc))))) + +(define + git/hex->raw + (fn (h) (git/hex->raw-go h 0 (string-length h) (list)))) diff --git a/lib/git/tests/dag.sx b/lib/git/tests/dag.sx new file mode 100644 index 00000000..e68d3c97 --- /dev/null +++ b/lib/git/tests/dag.sx @@ -0,0 +1,172 @@ +; Phase 3 — dag: log (topo), ancestry, is-ancestor?, reachability, merge-base, +; and the minimal Datalog ancestor-closure bridge. +; Fixtures: a linear chain, a diamond merge, a criss-cross (two LCAs), +; and two unrelated roots. + +(define gdt-db (persist/mem-backend)) +(define gdt (git/repo gdt-db)) + +(define + gdt-commit! + (fn + (msg parents) + (git/write gdt (git/commit (git/write-blob gdt msg) parents {:message msg})))) + +; linear chain c1 <- c2 <- c3 +(define gdt-c1 (gdt-commit! "c1" (list))) +(define gdt-c2 (gdt-commit! "c2" (list gdt-c1))) +(define gdt-c3 (gdt-commit! "c3" (list gdt-c2))) + +; diamond: b1 <- p, b1 <- q, m = merge(p q) +(define gdt-b1 (gdt-commit! "b1" (list))) +(define gdt-p (gdt-commit! "p" (list gdt-b1))) +(define gdt-q (gdt-commit! "q" (list gdt-b1))) +(define gdt-m (gdt-commit! "m" (list gdt-p gdt-q))) + +; criss-cross: base <- a, base <- b; x = merge(a b), y = merge(a b) via +; distinct messages so x != y +(define gdt-base (gdt-commit! "base" (list))) +(define gdt-a (gdt-commit! "a" (list gdt-base))) +(define gdt-b (gdt-commit! "b" (list gdt-base))) +(define gdt-x (gdt-commit! "x" (list gdt-a gdt-b))) +(define gdt-y (gdt-commit! "y" (list gdt-a gdt-b))) + +; unrelated root +(define gdt-lone (gdt-commit! "lone" (list))) + +; ---- parents ---- +(git-test + "parents of a root commit" + (= (git/parents gdt gdt-c1) (list)) + true) +(git-test + "parents of a merge commit" + (= (git/parents gdt gdt-m) (list gdt-p gdt-q)) + true) +(git-test + "parents of a non-commit cid" + (= (git/parents gdt "sx1:junk") (list)) + true) + +; ---- reachability ---- +(git-test + "reachable includes self" + (git/dag-member? gdt-c3 (git/reachable gdt gdt-c3)) + true) +(git-test + "reachable spans the chain" + (= (git/reachable gdt gdt-c3) (list gdt-c1 gdt-c2 gdt-c3)) + true) +(git-test + "reachable covers both diamond legs" + (len (git/reachable gdt gdt-m)) + 4) +(git-test + "reachable-all merges from several heads without duplicates" + (len (git/reachable-all gdt (list gdt-x gdt-y))) + 5) + +; ---- log: children before parents ---- +(git-test + "log on a chain is newest-first" + (= (git/log gdt gdt-c3) (list gdt-c3 gdt-c2 gdt-c1)) + true) +(git-test + "log messages read newest-first" + (= (git/log-messages gdt gdt-c3) (list "c3" "c2" "c1")) + true) +(git-test + "log of a diamond is a valid topo order" + (= (git/log gdt gdt-m) (list gdt-m gdt-q gdt-p gdt-b1)) + true) +(git-test + "log of a root is just the root" + (= (git/log gdt gdt-c1) (list gdt-c1)) + true) + +; ---- ancestors / is-ancestor? ---- +(git-test + "ancestors excludes self" + (git/dag-member? gdt-c3 (git/ancestors gdt gdt-c3)) + false) +(git-test + "ancestors of the chain tip" + (= (git/ancestors gdt gdt-c3) (list gdt-c1 gdt-c2)) + true) +(git-test + "ancestors of a merge include both legs and the base" + (len (git/ancestors gdt gdt-m)) + 3) +(git-test + "is-ancestor? along the chain" + (git/is-ancestor? gdt gdt-c1 gdt-c3) + true) +(git-test + "is-ancestor? is directed" + (git/is-ancestor? gdt gdt-c3 gdt-c1) + false) +(git-test + "is-ancestor? is reflexive" + (git/is-ancestor? gdt gdt-c2 gdt-c2) + true) +(git-test + "is-ancestor? false across unrelated history" + (git/is-ancestor? gdt gdt-c1 gdt-lone) + false) + +; ---- merge-base ---- +(git-test + "merge-base of the diamond legs is the base" + (git/merge-base gdt gdt-p gdt-q) + gdt-b1) +(git-test + "merge-base when one side is an ancestor is that side" + (git/merge-base gdt gdt-c1 gdt-c3) + gdt-c1) +(git-test "merge-base with self" (git/merge-base gdt gdt-c3 gdt-c3) gdt-c3) +(git-test + "merge-base of unrelated commits is nil" + (git/merge-base gdt gdt-c3 gdt-lone) + nil) +(git-test + "merge-base is symmetric" + (equal? (git/merge-base gdt gdt-p gdt-q) (git/merge-base gdt gdt-q gdt-p)) + true) +(git-test + "criss-cross yields BOTH best common ancestors" + (= + (git/merge-bases gdt gdt-x gdt-y) + (artdag/sort-strings (list gdt-a gdt-b))) + true) +(git-test + "dominated common ancestor is not a merge-base" + (git/dag-member? gdt-base (git/merge-bases gdt gdt-x gdt-y)) + false) + +; ---- Datalog bridge ---- +(git-test + "dag-facts exports one fact per parent edge" + (len (git/dag-facts gdt (list gdt-m))) + 4) +(git-test + "datalog ancestors match the SX-side walk" + (let + ((db (git/dag-db gdt (list gdt-m)))) + (= + (git/ancestors-dl db gdt-m) + (artdag/sort-strings (git/ancestors gdt gdt-m)))) + true) +(git-test + "datalog is-ancestor? positive" + (git/is-ancestor-dl? (git/dag-db gdt (list gdt-m)) gdt-b1 gdt-m) + true) +(git-test + "datalog is-ancestor? negative" + (git/is-ancestor-dl? (git/dag-db gdt (list gdt-m)) gdt-m gdt-b1) + false) +(git-test + "datalog closure spans the chain" + (= + (git/ancestors-dl (git/dag-db gdt (list gdt-c3)) gdt-c3) + (artdag/sort-strings (list gdt-c1 gdt-c2))) + true) diff --git a/lib/git/tests/diff.sx b/lib/git/tests/diff.sx new file mode 100644 index 00000000..ecbafa50 --- /dev/null +++ b/lib/git/tests/diff.sx @@ -0,0 +1,164 @@ +; Phase 5 — diff: Myers line diff (edit script + reconstruction invariants), +; unified hunk rendering, structural tree/commit diff. + +(define gdf-db (persist/mem-backend)) +(define gdf (git/repo gdf-db)) + +; ---- diff-lines ---- +(git-test + "lines drop the trailing newline slot" + (= (git/diff-lines "a\nb\n") (list "a" "b")) + true) +(git-test + "lines without trailing newline" + (= (git/diff-lines "a\nb") (list "a" "b")) + true) +(git-test "empty data has no lines" (= (git/diff-lines "") (list)) true) + +; ---- Myers edit script ---- +(git-test + "identical inputs are all-eq" + (git/diff-changes (git/diff-script "a\nb\nc\n" "a\nb\nc\n")) + 0) +(git-test + "identical inputs keep every line" + (len (git/diff-script "a\nb\nc\n" "a\nb\nc\n")) + 3) +(git-test + "empty vs empty is the empty script" + (= (git/diff-script "" "") (list)) + true) +(git-test + "single line replacement" + (= (git/diff-script "a" "b") (list {:op "del" :line "a"} {:op "add" :line "b"})) + true) +(git-test + "pure insertion script" + (= (git/diff-script "" "a\nb\n") (list {:op "add" :line "a"} {:op "add" :line "b"})) + true) +(git-test + "pure deletion script" + (= (git/diff-script "a\nb\n" "") (list {:op "del" :line "a"} {:op "del" :line "b"})) + true) +(git-test + "middle change keeps flanks eq" + (= + (git/diff-script "a\nb\nc\n" "a\nx\nc\n") + (list {:op "eq" :line "a"} {:op "del" :line "b"} {:op "add" :line "x"} {:op "eq" :line "c"})) + true) + +; Myers' paper example: ABCABBA -> CBABAC has a shortest edit script of 5 +(git-test + "ABCABBA/CBABAC shortest edit distance is 5" + (git/diff-changes (git/diff-script "A\nB\nC\nA\nB\nB\nA" "C\nB\nA\nB\nA\nC")) + 5) +(git-test + "script reconstructs the old side" + (= + (git/diff-old-lines (git/diff-script "A\nB\nC\nA\nB\nB\nA" "C\nB\nA\nB\nA\nC")) + (list "A" "B" "C" "A" "B" "B" "A")) + true) +(git-test + "script reconstructs the new side" + (= + (git/diff-new-lines (git/diff-script "A\nB\nC\nA\nB\nB\nA" "C\nB\nA\nB\nA\nC")) + (list "C" "B" "A" "B" "A" "C")) + true) +(git-test + "reconstruction holds for asymmetric edits" + (let + ((a "one\ntwo\nthree\nfour\n") (b "zero\ntwo\nfour\nfive\nsix\n")) + (and + (= (git/diff-old-lines (git/diff-script a b)) (git/diff-lines a)) + (= (git/diff-new-lines (git/diff-script a b)) (git/diff-lines b)))) + true) + +; ---- unified rendering ---- +(git-test + "unified: middle replacement, full context" + (git/diff-unified "a\nb\nc\n" "a\nx\nc\n") + "@@ -1,3 +1,3 @@\n a\n-b\n+x\n c\n") +(git-test + "unified: append at end" + (git/diff-unified "a\n" "a\nb\n") + "@@ -1,1 +1,2 @@\n a\n+b\n") +(git-test "unified: identical renders empty" (git/diff-unified "x\n" "x\n") "") +(git-test + "unified: creation from empty" + (git/diff-unified "" "a\nb\n") + "@@ -0,0 +1,2 @@\n+a\n+b\n") +(git-test + "unified: deletion to empty" + (git/diff-unified "a\nb\n" "") + "@@ -1,2 +0,0 @@\n-a\n-b\n") +(git-test + "unified: context trimmed to 3 lines" + (git/diff-unified "l1\nl2\nl3\nl4\nl5\nl6\nl7\nl8\nl9\n" "l1\nl2\nl3\nl4\nX\nl6\nl7\nl8\nl9\n") + "@@ -2,7 +2,7 @@\n l2\n l3\n l4\n-l5\n+X\n l6\n l7\n l8\n") +(git-test + "unified: distant changes split into two hunks" + (git/diff-unified + "l1\nl2\nl3\nl4\nl5\nl6\nl7\nl8\nl9\nl10\nl11\nl12\nl13\nl14\nl15\n" + "l1\nX\nl3\nl4\nl5\nl6\nl7\nl8\nl9\nl10\nl11\nl12\nl13\nY\nl15\n") + (str + "@@ -1,5 +1,5 @@\n l1\n-l2\n+X\n l3\n l4\n l5\n" + "@@ -11,5 +11,5 @@\n l11\n l12\n l13\n-l14\n+Y\n l15\n")) + +; ---- blob diff over the object store ---- +(git-test + "blob-diff reads both blobs" + (= + (git/blob-diff gdf (git/write-blob gdf "a\n") (git/write-blob gdf "b\n")) + (list {:op "del" :line "a"} {:op "add" :line "b"})) + true) + +; ---- structural tree/commit diff ---- +(define + gdf-t1 + (git/tree-from-files + gdf + (assoc + (assoc (assoc {} "a.txt" "1\n") "b.txt" "2\n") + "sub/c.txt" + "3\n"))) +(define + gdf-t2 + (git/tree-from-files + gdf + (assoc + (assoc (assoc {} "a.txt" "1\n") "b.txt" "2x\n") + "d.txt" + "new\n"))) +(define gdf-c1 (git/write gdf (git/commit gdf-t1 (list) {:message "c1"}))) +(define gdf-c2 (git/write gdf (git/commit gdf-t2 (list gdf-c1) {:message "c2"}))) + +(git-test + "tree-diff classifies added/modified/deleted" + (= (git/tree-diff gdf gdf-t1 gdf-t2) {:deleted (list "sub/c.txt") :modified (list "b.txt") :added (list "d.txt")}) + true) +(git-test + "tree-diff of a tree with itself is empty" + (= (git/tree-diff gdf gdf-t1 gdf-t1) {:deleted (list) :modified (list) :added (list)}) + true) +(git-test + "commit-diff goes through the commit trees" + (= (git/commit-diff gdf gdf-c1 gdf-c2) {:deleted (list "sub/c.txt") :modified (list "b.txt") :added (list "d.txt")}) + true) + +; ---- whole-commit unified render ---- +(git-test + "commit-diff-unified renders adds, deletes, then modifications" + (let + ((r (git/repo (persist/mem-backend)))) + (let + ((c1 (git/write r (git/commit (git/tree-from-files r (assoc {} "f.txt" "old\n")) (list) {:message "c1"})))) + (let + ((c2 (git/write r (git/commit (git/tree-from-files r (assoc (assoc {} "f.txt" "new\n") "g.txt" "hi\n")) (list c1) {:message "c2"})))) + (git/commit-diff-unified r c1 c2)))) + (str + "diff --sx a/g.txt b/g.txt\n--- /dev/null\n+++ b/g.txt\n@@ -0,0 +1,1 @@\n+hi\n" + "diff --sx a/f.txt b/f.txt\n--- a/f.txt\n+++ b/f.txt\n@@ -1,1 +1,1 @@\n-old\n+new\n")) +(git-test + "commit-diff-unified of identical commits is empty" + (git/commit-diff-unified gdf gdf-c1 gdf-c1) + "") diff --git a/lib/git/tests/export.sx b/lib/git/tests/export.sx new file mode 100644 index 00000000..60df24d3 --- /dev/null +++ b/lib/git/tests/export.sx @@ -0,0 +1,202 @@ +; Extension — git-wire export adapter. Golden values generated with real git +; (hash-object/mktree/commit-tree with pinned idents) — the adapter must +; reproduce byte-exact payloads and SHA-1s. + +; ---- SHA-1 vectors ---- +(git-test + "sha1 of empty" + (git/sha1-hex "") + "da39a3ee5e6b4b0d3255bfef95601890afd80709") +(git-test + "sha1 of abc" + (git/sha1-hex "abc") + "a9993e364706816aba3e25717850c26c9cd0d89d") +(git-test + "sha1 crossing the padding boundary" + (git/sha1-hex "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq") + "84983e441c3bd26ebaae4aa1f95129e5e54670f1") +(define + gex-rep + (fn + (s n) + (if (= n 0) "" (str s (gex-rep s (- n 1)))))) +(git-test + "sha1 over multiple blocks" + (git/sha1-hex (gex-rep "a" 200)) + "e61cfffe0d9195a525fc6cf06ca2d77119c24a40") +(git-test + "raw digest is 20 bytes" + (= (string-length (git/sha1-raw "abc")) 20) + true) +(git-test + "hex->raw round-trips through byte codes" + (char-code (substring (git/hex->raw "ff00a1") 1 2)) + 0) + +; ---- fixture (mirrors the golden git repo exactly) ---- +(define gex-db (persist/mem-backend)) +(define gex (git/repo gex-db)) +(define gex-hello (git/write-blob gex "hello\n")) +(define gex-sub (git/write-blob gex "sub\n")) +(define gex-hello2 (git/write-blob gex "hello2\n")) +(define gex-subtxt (git/write-blob gex "not a dir\n")) +(define + gex-tsub + (git/write + gex + (git/tree (assoc {} "c.txt" (git/tree-entry "blob" gex-sub))))) +(define + gex-t1 + (git/write + gex + (git/tree + (assoc + (assoc {} "a.txt" (git/tree-entry "blob" gex-hello)) + "sub" + (git/tree-entry "tree" gex-tsub))))) +(define + gex-t2 + (git/write + gex + (git/tree + (assoc + (assoc {} "a.txt" (git/tree-entry "blob" gex-hello2)) + "sub" + (git/tree-entry "tree" gex-tsub))))) +(define + gex-t3 + (git/write + gex + (git/tree + (assoc + (assoc + (assoc {} "a.txt" (git/tree-entry "blob" gex-hello)) + "sub" + (git/tree-entry "tree" gex-tsub)) + "sub.txt" + (git/tree-entry "blob" gex-subtxt))))) +(define + gex-t4 + (git/write + gex + (git/tree + (assoc + {} + "x.sh" + (merge (git/tree-entry "blob" gex-hello) {:mode "100755"}))))) +(define gex-c1 (git/write gex (git/commit gex-t1 (list) {:message "c1" :tz "+0000" :email "ada@sx" :time 1700000000 :author "ada"}))) +(define gex-c2 (git/write gex (git/commit gex-t2 (list gex-c1) {:message "c2" :tz "+0000" :email "ada@sx" :time 1700000100 :author "ada"}))) +(define gex-tag (git/write gex (git/tag gex-c1 "v1" {:message "first" :tz "+0000" :email "ada@sx" :time 1700000200 :author "ada"}))) + +; ---- blob payloads ---- +(git-test + "blob export matches git hash-object" + (git/export-sha gex gex-hello) + "ce013625030ba8dba906f756967f9e9ca394464a") +(git-test + "empty blob is git's famous e69de29" + (git/export-sha gex (git/write-blob gex "")) + "e69de29bb2d1d6434b8b29ae775ad8c2e48c5391") +(git-test + "blob payload bytes are ' NUL'" + (equal? + (get (git/export gex gex-hello) :bytes) + (str "blob 6" git/export-nul "hello\n")) + true) + +; ---- tree payloads (git sort rules, raw child shas) ---- +(git-test + "leaf tree matches git mktree" + (git/export-sha gex gex-tsub) + "2282cb13a4b7999406280aac69e4fc45260fb909") +(git-test + "nested tree matches git mktree" + (git/export-sha gex gex-t1) + "77918032f1f02d785d3bc222ab29b4969cd83854") +(git-test + "modified tree matches git mktree" + (git/export-sha gex gex-t2) + "aaf1022f60da7b14837d52232a75fa3fc2d3e3a7") +(git-test + "directories sort as 'name/': sub.txt before dir sub" + (git/export-sha gex gex-t3) + "58c19e599aa988a4ee6fba065f8801c700777a3d") +(git-test + "entry :mode override (100755) is honored" + (git/export-sha gex gex-t4) + "54925a269ee97325d7da275bda4250d83b338e65") +(git-test + "the empty tree is git's 4b825dc" + (git/export-sha gex (git/write gex (git/tree {}))) + "4b825dc642cb6eb9a060e54bf8d69288fbee4904") + +; ---- commit payloads ---- +(git-test + "root commit matches git commit-tree" + (git/export-sha gex gex-c1) + "baeeb137fc255e62c1e3b980e70b2d8dd2be6e83") +(git-test + "child commit matches git commit-tree -p" + (git/export-sha gex gex-c2) + "a8eac1e101bf4f6b7d614a4384592a981a67ce92") +(git-test + "commit body is byte-exact" + (get (git/export gex gex-c1) :bytes) + (str + "commit 127" + git/export-nul + "tree 77918032f1f02d785d3bc222ab29b4969cd83854\n" + "author ada 1700000000 +0000\n" + "committer ada 1700000000 +0000\n" + "\n" + "c1\n")) + +; ---- tag payload ---- +(git-test + "annotated tag matches git hash-object -t tag" + (git/export-sha gex gex-tag) + "b28ebfd4213f10fd0c2127d1d14a26179fcf12e0") +(git-test + "tag body names the target type" + (contains? (get (git/export gex gex-tag) :bytes) "type commit") + true) + +; ---- closure + set ---- +(git-test + "closure of the child commit covers all 8 reachable objects" + (len (keys (git/export-closure gex gex-c2))) + 8) +(git-test + "closure of the tag reaches through the commit" + (len (keys (git/export-closure gex gex-tag))) + 6) +(git-test + "export-set is keyed by git sha with the head marked" + (let + ((s (git/export-set gex gex-c2))) + (list + (get s :head) + (get + (get (get s :objects) "baeeb137fc255e62c1e3b980e70b2d8dd2be6e83") + :type))) + (list "a8eac1e101bf4f6b7d614a4384592a981a67ce92" "commit")) + +; ---- defaults + trailing newline rule ---- +(git-test + "idents default deterministically" + (contains? + (get + (git/export gex (git/write gex (git/commit gex-t1 (list) {:message "m\n"}))) + :bytes) + "author sx 0 +0000") + true) +(git-test + "message gains a trailing newline when missing" + (let + ((e1 (git/export gex (git/write gex (git/commit gex-t1 (list) {:message "m"})))) + (e2 + (git/export + gex + (git/write gex (git/commit gex-t1 (list) {:message "m\n" :x 1}))))) + (equal? (get e1 :sha1) (get e2 :sha1))) + true) diff --git a/lib/git/tests/import.sx b/lib/git/tests/import.sx new file mode 100644 index 00000000..db36f295 --- /dev/null +++ b/lib/git/tests/import.sx @@ -0,0 +1,174 @@ +; Extension — git-wire import (inverse adapter). The law under test: +; export-set -> import-set -> export-set is BYTE-IDENTICAL (same head sha, +; same object table), and imported blobs/trees with default modes get the +; same native cids as the originals. + +(define gim-db (persist/mem-backend)) +(define gim (git/repo gim-db)) +(define gim-hello (git/write-blob gim "hello\n")) +(define gim-sub (git/write-blob gim "sub\n")) +(define + gim-tsub + (git/write + gim + (git/tree (assoc {} "c.txt" (git/tree-entry "blob" gim-sub))))) +(define + gim-t1 + (git/write + gim + (git/tree + (assoc + (assoc {} "a.txt" (git/tree-entry "blob" gim-hello)) + "sub" + (git/tree-entry "tree" gim-tsub))))) +(define gim-c1 (git/write gim (git/commit gim-t1 (list) {:message "c1" :tz "+0000" :email "ada@sx" :time 1700000000 :author "ada"}))) +(define + gim-c2 + (git/write + gim + (git/commit + (git/write + gim + (git/tree + (assoc + (assoc + {} + "a.txt" + (git/tree-entry "blob" (git/write-blob gim "hello2\n"))) + "sub" + (git/tree-entry "tree" gim-tsub)))) + (list gim-c1) + {:message "c2" :tz "+0000" :email "ada@sx" :time 1700000100 :author "ada"}))) + +; ---- parsing units ---- +(git-test + "payload splits type and body" + (git/import-payload (str "blob 6" git/export-nul "hello\n")) + {:type "blob" :body "hello\n"}) +(git-test + "ident parses name/email/time/tz" + (= (git/import-ident "ada lovelace 1700000000 +0100") {:name "ada lovelace" :tz "+0100" :email "ada@sx" :time 1700000000}) + true) +(git-test + "raw->hex inverts hex->raw" + (git/raw->hex (git/hex->raw "ce013625030ba8dba906f756967f9e9ca394464a")) + "ce013625030ba8dba906f756967f9e9ca394464a") +(git-test + "tree body parses mode/name/sha triples" + (= + (map + (fn (e) (get e :name)) + (git/import-tree-entries + (get + (git/import-payload (get (git/export gim gim-t1) :bytes)) + :body) + 0 + (string-length + (get + (git/import-payload (get (git/export gim gim-t1) :bytes)) + :body)) + (list))) + (list "a.txt" "sub")) + true) + +; ---- the round-trip law ---- +(define gim-set1 (git/export-set gim gim-c2)) +(define gim-fresh (git/repo-named (persist/mem-backend) "imported")) +(define gim-head (git/import-set gim-fresh gim-set1)) +(define gim-set2 (git/export-set gim-fresh gim-head)) + +(git-test + "wire round-trip: head sha is identical" + (get gim-set2 :head) + (get gim-set1 :head)) +(git-test + "wire round-trip: same number of objects" + (= + (len (keys (get gim-set2 :objects))) + (len (keys (get gim-set1 :objects)))) + true) +(git-test + "wire round-trip: every sha re-exports byte-identical" + (reduce + (fn + (acc sha) + (and + acc + (equal? + (get (get (get gim-set2 :objects) sha) :bytes) + (get (get (get gim-set1 :objects) sha) :bytes)))) + true + (keys (get gim-set1 :objects))) + true) + +; ---- native identity on the wire-expressible subset ---- +(git-test + "imported blob has the original native cid" + (git/has? gim-fresh gim-hello) + true) +(git-test + "imported default-mode tree has the original native cid" + (git/has? gim-fresh gim-t1) + true) +(git-test + "imported commit graph walks natively" + (= (git/log-messages gim-fresh gim-head) (list "c2\n" "c1\n")) + true) +(git-test + "imported parents map to native cids" + (= + (git/parents gim-fresh gim-head) + (list + (git/cid + (git/read gim-fresh (first (git/parents gim-fresh gim-head)))))) + true) + +; ---- mode + tag + committer round-trips ---- +(git-test + "non-default mode survives the round-trip" + (let + ((r (git/repo (persist/mem-backend)))) + (let + ((t (git/write r (git/tree (assoc {} "x.sh" (merge (git/tree-entry "blob" (git/write-blob r "hello\n")) {:mode "100755"})))))) + (let + ((s1 (git/export-set r t))) + (let + ((r2 (git/repo-named (persist/mem-backend) "i"))) + (get (git/export-set r2 (git/import-set r2 s1)) :head))))) + "54925a269ee97325d7da275bda4250d83b338e65") +(git-test + "annotated tag round-trips through the wire" + (let + ((tag (git/write gim (git/tag gim-c1 "v1" {:message "first" :tz "+0000" :email "ada@sx" :time 1700000200 :author "ada"})))) + (let + ((s1 (git/export-set gim tag))) + (let + ((r2 (git/repo-named (persist/mem-backend) "i"))) + (equal? + (get (git/export-set r2 (git/import-set r2 s1)) :head) + (get s1 :head))))) + true) +(git-test + "distinct committer survives the round-trip" + (let + ((c (git/write gim (git/commit gim-t1 (list) {:message "handoff" :committer "bob" :committer-tz "+0200" :tz "+0000" :committer-email "bob@sx" :email "ada@sx" :committer-time 1700000300 :time 1700000000 :author "ada"})))) + (let + ((s1 (git/export-set gim c))) + (let + ((r2 (git/repo-named (persist/mem-backend) "i"))) + (equal? + (get (git/export-set r2 (git/import-set r2 s1)) :head) + (get s1 :head))))) + true) +(git-test + "multi-line message round-trips byte-exact" + (let + ((c (git/write gim (git/commit gim-t1 (list) {:message "subject\n\nbody line one\nbody line two\n" :tz "+0000" :email "ada@sx" :time 1 :author "ada"})))) + (let + ((s1 (git/export-set gim c))) + (let + ((r2 (git/repo-named (persist/mem-backend) "i"))) + (equal? + (get (git/export-set r2 (git/import-set r2 s1)) :head) + (get s1 :head))))) + true) diff --git a/lib/git/tests/merge.sx b/lib/git/tests/merge.sx new file mode 100644 index 00000000..243e5b29 --- /dev/null +++ b/lib/git/tests/merge.sx @@ -0,0 +1,235 @@ +; Phase 6 — merge: textual diff3 with conflict markers, per-path 3-way tree +; merge with blob auto-merge, fast-forward/up-to-date detection. + +(define gmg-db (persist/mem-backend)) +(define gmg (git/repo gmg-db)) + +(define + gmg-commit! + (fn + (files parents msg) + (git/write + gmg + (git/commit (git/tree-from-files gmg files) parents {:message msg})))) + +; ---- textual 3-way ---- +(git-test "merge3: untouched" (git/merge3-text "x\n" "x\n" "x\n") {:clean true :text "x\n" :conflicts 0}) +(git-test + "merge3: ours-only change wins" + (get (git/merge3-text "a\nb\n" "a\nB\n" "a\nb\n") :text) + "a\nB\n") +(git-test + "merge3: theirs-only change wins" + (get (git/merge3-text "a\nb\n" "a\nb\n" "a\nB\n") :text) + "a\nB\n") +(git-test + "merge3: identical change on both sides is clean" + (git/merge3-text "a\nb\n" "a\nZ\n" "a\nZ\n") + {:clean true :text "a\nZ\n" :conflicts 0}) +(git-test + "merge3: non-overlapping changes both apply" + (git/merge3-text "a\nb\nc\n" "A\nb\nc\n" "a\nb\nC\n") + {:clean true :text "A\nb\nC\n" :conflicts 0}) +(git-test + "merge3: adjacent line changes merge cleanly" + (get (git/merge3-text "l1\nl2\nl3\nl4\n" "l1\nX\nl3\nl4\n" "l1\nl2\nY\nl4\n") :text) + "l1\nX\nY\nl4\n") +(git-test + "merge3: append and prepend both apply" + (get (git/merge3-text "m\n" "m\ne\n" "s\nm\n") :text) + "s\nm\ne\n") +(git-test + "merge3: clean deletion" + (get (git/merge3-text "a\nb\nc\n" "a\nc\n" "a\nb\nc\n") :text) + "a\nc\n") + +(git-test + "merge3: overlapping edits conflict with diff3 markers" + (git/merge3-text "a\nb\nc\n" "a\nX\nc\n" "a\nY\nc\n") + {:clean false :text "a\n<<<<<<< ours\nX\n||||||| base\nb\n=======\nY\n>>>>>>> theirs\nc\n" :conflicts 1}) +(git-test + "merge3: delete vs modify conflicts" + (git/merge3-text "a\nb\nc\n" "a\nc\n" "a\nY\nc\n") + {:clean false :text "a\n<<<<<<< ours\n||||||| base\nb\n=======\nY\n>>>>>>> theirs\nc\n" :conflicts 1}) +(git-test + "merge3: same-point insertions with different content conflict" + (git/merge3-text "" "A\n" "B\n") + {:clean false :text "<<<<<<< ours\nA\n||||||| base\n=======\nB\n>>>>>>> theirs\n" :conflicts 1}) +(git-test + "merge3: same-point insertions with the same content are clean" + (git/merge3-text "a\n" "a\nx\n" "a\nx\n") + {:clean true :text "a\nx\n" :conflicts 0}) +(git-test + "merge3: two separated conflicts are counted" + (get + (git/merge3-text + "a\nb\nc\nd\ne\nf\ng\nh\ni\n" + "a\nX1\nc\nd\ne\nf\ng\nX2\ni\n" + "a\nY1\nc\nd\ne\nf\ng\nY2\ni\n") + :conflicts) + 2) + +; ---- tree-from-cids ---- +(git-test + "tree-from-cids equals tree-from-files" + (equal? + (git/tree-from-cids + gmg + (assoc + (assoc {} "a.txt" (git/write-blob gmg "1\n")) + "s/b.txt" + (git/write-blob gmg "2\n"))) + (git/tree-from-files + gmg + (assoc (assoc {} "a.txt" "1\n") "s/b.txt" "2\n"))) + true) + +; ---- tree merge ---- +(define + gmg-base-files + (assoc (assoc {} "f.txt" "a\nb\nc\n") "g.txt" "same\n")) +(define gmg-base-tree (git/tree-from-files gmg gmg-base-files)) + +(git-test + "merge-trees: disjoint paths merge clean" + (let + ((ta (git/tree-from-files gmg (assoc gmg-base-files "ours.txt" "o\n"))) + (tb (git/tree-from-files gmg (assoc gmg-base-files "theirs.txt" "t\n")))) + (let + ((m (git/merge-trees gmg gmg-base-tree ta tb))) + (list + (get m :conflicts) + (= + (git/tree-files gmg (git/tree-from-cids gmg (get m :files))) + (assoc (assoc gmg-base-files "ours.txt" "o\n") "theirs.txt" "t\n"))))) + (list (list) true)) +(git-test + "merge-trees: same file, non-overlapping lines auto-merge" + (let + ((ta (git/tree-from-files gmg (assoc gmg-base-files "f.txt" "A\nb\nc\n"))) + (tb (git/tree-from-files gmg (assoc gmg-base-files "f.txt" "a\nb\nC\n")))) + (let + ((m (git/merge-trees gmg gmg-base-tree ta tb))) + (list + (get m :conflicts) + (git/blob-data (git/read gmg (get (get m :files) "f.txt")))))) + (list (list) "A\nb\nC\n")) +(git-test + "merge-trees: overlapping edits flag the path" + (let + ((ta (git/tree-from-files gmg (assoc gmg-base-files "f.txt" "a\nX\nc\n"))) + (tb (git/tree-from-files gmg (assoc gmg-base-files "f.txt" "a\nY\nc\n")))) + (let + ((m (git/merge-trees gmg gmg-base-tree ta tb))) + (= + (list + (get m :conflicts) + (contains? + (git/blob-data (git/read gmg (get (get m :files) "f.txt"))) + "<<<<<<< ours")) + (list (list "f.txt") true)))) + true) +(git-test + "merge-trees: both delete is clean" + (let + ((ta (git/tree-from-files gmg (dissoc gmg-base-files "f.txt"))) + (tb (git/tree-from-files gmg (dissoc gmg-base-files "f.txt")))) + (let + ((m (git/merge-trees gmg gmg-base-tree ta tb))) + (list (get m :conflicts) (has-key? (get m :files) "f.txt")))) + (list (list) false)) +(git-test + "merge-trees: delete vs modify keeps the modified side and flags it" + (let + ((ta (git/tree-from-files gmg (dissoc gmg-base-files "f.txt"))) + (tb (git/tree-from-files gmg (assoc gmg-base-files "f.txt" "a\nY\nc\n")))) + (let + ((m (git/merge-trees gmg gmg-base-tree ta tb))) + (= + (list + (get m :conflicts) + (git/blob-data (git/read gmg (get (get m :files) "f.txt")))) + (list (list "f.txt") "a\nY\nc\n")))) + true) +(git-test + "merge-trees: both add the same file identically" + (let + ((ta (git/tree-from-files gmg (assoc gmg-base-files "n.txt" "n\n"))) + (tb (git/tree-from-files gmg (assoc gmg-base-files "n.txt" "n\n")))) + (get (git/merge-trees gmg gmg-base-tree ta tb) :conflicts)) + (list)) +(git-test + "merge-trees: both add the same file differently" + (let + ((ta (git/tree-from-files gmg (assoc gmg-base-files "n.txt" "N1\n"))) + (tb (git/tree-from-files gmg (assoc gmg-base-files "n.txt" "N2\n")))) + (= + (get (git/merge-trees gmg gmg-base-tree ta tb) :conflicts) + (list "n.txt"))) + true) + +; ---- commit-level ---- +(define gmg-c0 (gmg-commit! gmg-base-files (list) "base")) +(define + gmg-ca + (gmg-commit! (assoc gmg-base-files "f.txt" "A\nb\nc\n") (list gmg-c0) "ours")) +(define + gmg-cb + (gmg-commit! + (assoc gmg-base-files "f.txt" "a\nb\nC\n") + (list gmg-c0) + "theirs")) +(define + gmg-cx + (gmg-commit! (assoc gmg-base-files "f.txt" "a\nX\nc\n") (list gmg-c0) "ox")) +(define + gmg-cy + (gmg-commit! (assoc gmg-base-files "f.txt" "a\nY\nc\n") (list gmg-c0) "oy")) + +(git-test "ff? when ours is behind" (git/ff? gmg gmg-c0 gmg-ca) true) +(git-test "ff? false for diverged heads" (git/ff? gmg gmg-ca gmg-cb) false) +(git-test + "merge-commits: up-to-date when theirs is an ancestor" + (git/merge-commits gmg gmg-ca gmg-c0) + {:cid gmg-ca :result "up-to-date"}) +(git-test + "merge-commits: fast-forward when ours is an ancestor" + (git/merge-commits gmg gmg-c0 gmg-ca) + {:cid gmg-ca :result "fast-forward"}) +(git-test + "merge-commits: clean 3-way produces the merged tree" + (let + ((m (git/merge-commits gmg gmg-ca gmg-cb))) + (list + (get m :result) + (get m :conflicts) + (= + (git/tree-files gmg (get m :tree)) + (assoc gmg-base-files "f.txt" "A\nb\nC\n")))) + (list "merged" (list) true)) +(git-test + "merge-commits: conflicting 3-way reports paths and marker tree" + (let + ((m (git/merge-commits gmg gmg-cx gmg-cy))) + (= + (list + (get m :result) + (get m :conflicts) + (contains? + (get (git/tree-files gmg (get m :tree)) "f.txt") + ">>>>>>> theirs")) + (list "conflicts" (list "f.txt") true))) + true) +(git-test + "merge-commits: unrelated histories merge over an empty base" + (let + ((r1 (gmg-commit! (assoc {} "x.txt" "x\n") (list) "rx")) + (r2 (gmg-commit! (assoc {} "y.txt" "y\n") (list) "ry"))) + (let + ((m (git/merge-commits gmg r1 r2))) + (list + (get m :result) + (= + (git/tree-files gmg (get m :tree)) + (assoc (assoc {} "x.txt" "x\n") "y.txt" "y\n"))))) + (list "merged" true)) diff --git a/lib/git/tests/object.sx b/lib/git/tests/object.sx new file mode 100644 index 00000000..1ba9bc9d --- /dev/null +++ b/lib/git/tests/object.sx @@ -0,0 +1,241 @@ +; Phase 1 — object: blob/tree/commit/tag as content-addressed typed objects. +; Fixture repo: blobs a/b/c, nested tree (a.txt b.txt sub/c.txt), two commits +; (c2 modifies a.txt, parent c1), tag v1 -> c1. Reused as the assertion target. + +(define git-fix-db (persist/mem-backend)) +(define git-fix (git/repo git-fix-db)) + +(define git-fix-blob-a (git/write-blob git-fix "hello\n")) +(define git-fix-blob-b (git/write-blob git-fix "world\n")) +(define git-fix-blob-c (git/write-blob git-fix "sub\n")) +(define git-fix-blob-a2 (git/write-blob git-fix "hello2\n")) + +(define + git-fixt-entries3 + (fn + (acid bcid subcid) + (assoc + (assoc + (assoc {} "a.txt" (git/tree-entry "blob" acid)) + "b.txt" + (git/tree-entry "blob" bcid)) + "sub" + (git/tree-entry "tree" subcid)))) + +(define + git-fix-subtree-cid + (git/write + git-fix + (git/tree + (assoc {} "c.txt" (git/tree-entry "blob" git-fix-blob-c))))) + +(define + git-fix-tree1-cid + (git/write + git-fix + (git/tree + (git-fixt-entries3 git-fix-blob-a git-fix-blob-b git-fix-subtree-cid)))) + +(define + git-fix-tree2-cid + (git/write + git-fix + (git/tree + (git-fixt-entries3 git-fix-blob-a2 git-fix-blob-b git-fix-subtree-cid)))) + +(define + git-fix-commit1-cid + (git/write git-fix (git/commit git-fix-tree1-cid (list) {:message "c1" :time 1 :author "ada"}))) + +(define + git-fix-commit2-cid + (git/write + git-fix + (git/commit git-fix-tree2-cid (list git-fix-commit1-cid) {:message "c2" :time 2 :author "ada"}))) + +(define + git-fix-tag-cid + (git/write git-fix (git/tag git-fix-commit1-cid "v1" {:message "first" :tagger "ada"}))) + +; ---- constructors + types ---- +(git-test "blob is typed" (git/object-type (git/blob "x")) "blob") +(git-test "blob? true on blob" (git/blob? (git/blob "x")) true) +(git-test + "blob? false on commit" + (git/blob? (git/commit "t" (list) {})) + false) +(git-test "tree? true on tree" (git/tree? (git/tree {})) true) +(git-test + "commit? true on commit" + (git/commit? (git/commit "t" (list) {})) + true) +(git-test "tag? true on tag" (git/tag? (git/tag "c" "v" {})) true) +(git-test "blob-data reads back" (git/blob-data (git/blob "hi")) "hi") + +; ---- cid: deterministic structural identity ---- +(git-test + "cid deterministic" + (equal? (git/cid (git/blob "same")) (git/cid (git/blob "same"))) + true) +(git-test + "cid differs by content" + (equal? (git/cid (git/blob "a")) (git/cid (git/blob "b"))) + false) +(git-test + "cid ignores dict insertion order" + (equal? + (git/cid (assoc (assoc {} :type "blob") :data "x")) + (git/cid (assoc (assoc {} :data "x") :type "blob"))) + true) +(git-test + "cid carries the native scheme prefix" + (starts-with? (git/cid (git/blob "x")) "sx1:") + true) + +; ---- write / read / has ---- +(git-test + "write returns the object cid" + (equal? git-fix-blob-a (git/cid (git/blob "hello\n"))) + true) +(git-test + "read round-trips blob data" + (git/blob-data (git/read git-fix git-fix-blob-a)) + "hello\n") +(git-test + "read round-trips structurally" + (equal? (git/read git-fix git-fix-blob-a) (git/blob "hello\n")) + true) +(git-test "has? true after write" (git/has? git-fix git-fix-blob-a) true) +(git-test "has? false for unknown cid" (git/has? git-fix "sx1:nope") false) +(git-test "read unknown cid gives nil" (git/read git-fix "sx1:nope") nil) +(git-test + "rewrite is idempotent, same cid" + (equal? (git/write git-fix (git/blob "hello\n")) git-fix-blob-a) + true) + +; ---- structural identity across separately built objects ---- +(git-test + "separately built identical tree shares the cid" + (equal? + (git/write + git-fix + (git/tree + (git-fixt-entries3 git-fix-blob-a git-fix-blob-b git-fix-subtree-cid))) + git-fix-tree1-cid) + true) +(git-test + "changed entry changes the tree cid" + (equal? git-fix-tree1-cid git-fix-tree2-cid) + false) + +; ---- tree accessors ---- +(git-test + "tree entry lookup by name" + (git/entry-cid + (git/tree-entry-for (git/read git-fix git-fix-tree1-cid) "a.txt")) + git-fix-blob-a) +(git-test + "tree entry kind" + (git/entry-kind + (git/tree-entry-for (git/read git-fix git-fix-tree1-cid) "sub")) + "tree") +(git-test + "tree-names sorted" + (= + (git/tree-names (git/read git-fix git-fix-tree1-cid)) + (list "a.txt" "b.txt" "sub")) + true) + +; ---- commit accessors ---- +(git-test + "commit tree cid" + (git/commit-tree (git/read git-fix git-fix-commit1-cid)) + git-fix-tree1-cid) +(git-test + "root commit has no parents" + (git/commit-parents (git/read git-fix git-fix-commit1-cid)) + (list)) +(git-test + "child commit records its parent" + (git/commit-parents (git/read git-fix git-fix-commit2-cid)) + (list git-fix-commit1-cid)) +(git-test + "commit author round-trips" + (git/commit-author (git/read git-fix git-fix-commit1-cid)) + "ada") +(git-test + "commit message round-trips" + (git/commit-message (git/read git-fix git-fix-commit2-cid)) + "c2") +(git-test + "commit cids differ across history" + (equal? git-fix-commit1-cid git-fix-commit2-cid) + false) + +; ---- typed extensibility (the reason for native CID) ---- +(git-test + "extra commit field round-trips" + (get + (git/read + git-fix + (git/write git-fix (git/commit "t" (list) {:message "m" :co-authored-by "claude"}))) + :co-authored-by) + "claude") +(git-test + "extra field changes the cid" + (equal? + (git/cid (git/commit "t" (list) {:m 1})) + (git/cid (git/commit "t" (list) {}))) + false) +(git-test + "protected keys win over meta" + (git/commit-tree (git/commit "t" (list) {:tree "evil"})) + "t") + +; ---- tag ---- +(git-test + "tag target" + (git/tag-target (git/read git-fix git-fix-tag-cid)) + git-fix-commit1-cid) +(git-test "tag name" (git/tag-name (git/read git-fix git-fix-tag-cid)) "v1") +(git-test + "tag? on read-back" + (git/tag? (git/read git-fix git-fix-tag-cid)) + true) + +; ---- full walk: commit -> tree -> subtree -> blob ---- +(git-test + "walk commit to nested blob" + (git/blob-data + (git/read + git-fix + (git/entry-cid + (git/tree-entry-for + (git/read + git-fix + (git/entry-cid + (git/tree-entry-for + (git/read + git-fix + (git/commit-tree (git/read git-fix git-fix-commit1-cid))) + "sub"))) + "c.txt")))) + "sub\n") + +; ---- repos are namespaced within one backend ---- +(git-test + "objects are invisible across repo namespaces" + (let + ((db (persist/mem-backend))) + (let + ((ra (git/repo-named db "a")) (rb (git/repo-named db "b"))) + (let ((cid (git/write-blob ra "x"))) (git/has? rb cid)))) + false) +(git-test + "same content, same cid in any repo" + (let + ((db (persist/mem-backend))) + (equal? + (git/write-blob (git/repo-named db "a") "x") + (git/write-blob (git/repo-named db "b") "x"))) + true) diff --git a/lib/git/tests/porcelain.sx b/lib/git/tests/porcelain.sx new file mode 100644 index 00000000..4ab18ba9 --- /dev/null +++ b/lib/git/tests/porcelain.sx @@ -0,0 +1,261 @@ +; Phase 7 — porcelain: init/add/commit/branch/checkout/tag/reset/merge/log/diff +; as one end-to-end topology story, plus the conflicted-merge flow. + +(define gpc-db (persist/mem-backend)) +(define gpc (git/init! gpc-db "proj")) + +; ---- init ---- +(git-test + "init points HEAD at an unborn main" + (git/head-target gpc) + "heads/main") +(git-test "init has no commits yet" (git/head gpc) nil) +(git-test + "init status is clean and empty" + (= (git/status gpc {}) {:untracked (list) :staged {:deleted (list) :modified (list) :added (list)} :unstaged {:deleted (list) :modified (list)}}) + true) + +; ---- first commit on main ---- +(git-test + "staged files show before the first commit" + (begin + (git/add! gpc "README.md" "hello\n") + (git/add! gpc "src/main.sx" "(main)\n") + (= + (get (get (git/status gpc {}) :staged) :added) + (list "README.md" "src/main.sx"))) + true) + +(define gpc-c1 (git/commit! gpc {:message "c1" :author "ada"})) + +(git-test "commit! advances HEAD through main" (git/head gpc) gpc-c1) +(git-test "commit! moved the branch ref" (git/branch-get gpc "main") gpc-c1) +(git-test + "the commit carries the author" + (git/commit-author (git/read gpc gpc-c1)) + "ada") +(git-test + "first commit has no parents" + (= (git/commit-parents (git/read gpc gpc-c1)) (list)) + true) +(git-test + "commit materializes the staged files" + (= + (git/commit-files gpc gpc-c1) + (assoc (assoc {} "README.md" "hello\n") "src/main.sx" "(main)\n")) + true) +(git-test "after commit! the index is clean" (git/diff-staged gpc) "") +(git-test + "extensible meta flows through porcelain" + (let + ((r (git/init! (persist/mem-backend) "x"))) + (begin + (git/add! r "f" "1\n") + (get (git/read r (git/commit! r {:message "m" :agent "claude-fable"})) :agent))) + "claude-fable") + +; ---- branch + checkout ---- +(git-test "branch! forks at HEAD" (git/branch! gpc "feature") gpc-c1) +(git-test + "checkout! returns the materialized worktree" + (= (git/checkout! gpc "feature") (git/commit-files gpc gpc-c1)) + true) +(git-test "checkout! retargets HEAD" (git/head-target gpc) "heads/feature") + +(define + gpc-c2 + (begin + (git/add! gpc "src/feature.sx" "(feature)\n") + (git/commit! gpc {:message "c2" :author "ada"}))) + +(git-test + "feature moved, main did not" + (= + (list (git/branch-get gpc "feature") (git/branch-get gpc "main")) + (list gpc-c2 gpc-c1)) + true) +(git-test + "checkout back to main drops the feature file" + (has-key? (git/checkout! gpc "main") "src/feature.sx") + false) + +(define + gpc-c3 + (begin + (git/add! gpc "README.md" "hello\nworld\n") + (git/commit! gpc {:message "c3" :author "ada"}))) + +; ---- real merge ---- +(define gpc-m (git/merge! gpc "feature" {:message "merge feature" :author "ada"})) + +(git-test + "diverged branches produce a merge commit" + (get gpc-m :result) + "merged") +(git-test + "merge commit has both parents in order" + (= + (git/commit-parents (git/read gpc (get gpc-m :cid))) + (list gpc-c3 gpc-c2)) + true) +(git-test + "merge result is where HEAD is now" + (git/head gpc) + (get gpc-m :cid)) +(git-test + "merged tree unions both changes" + (= + (git/commit-files gpc (git/head gpc)) + (assoc + (assoc + (assoc {} "README.md" "hello\nworld\n") + "src/main.sx" + "(main)\n") + "src/feature.sx" + "(feature)\n")) + true) +(git-test "no merge left in progress" (git/merge-in-progress? gpc) false) +(git-test + "log walks the merged topology newest-first" + (= + (git/log-messages gpc (git/head gpc)) + (list "merge feature" "c2" "c3" "c1")) + true) +(git-test + "merge-base of the two legs is the fork point" + (git/merge-base gpc gpc-c2 gpc-c3) + gpc-c1) + +; ---- fast-forward + up-to-date ---- +(define gpc-c4 (get gpc-m :cid)) +(define + gpc-c5 + (begin + (git/branch! gpc "hotfix") + (git/checkout! gpc "hotfix") + (git/add! gpc "fix.txt" "patched\n") + (git/commit! gpc {:message "c5" :author "ada"}))) + +(git-test + "merging a descendant fast-forwards" + (begin + (git/checkout! gpc "main") + (get (git/merge! gpc "hotfix" {:message "unused"}) :result)) + "fast-forward") +(git-test + "fast-forward moved main to the hotfix tip" + (git/branch-get gpc "main") + gpc-c5) +(git-test + "merging it again is up-to-date" + (get (git/merge! gpc "hotfix" {:message "unused"}) :result) + "up-to-date") + +; ---- tags ---- +(git-test + "tag! writes an annotated tag object at HEAD" + (begin + (git/tag! gpc "v1" {:tagger "ada"}) + (git/tag-target (git/read gpc (git/tag-get gpc "v1")))) + gpc-c5) +(git-test + "lightweight tag points straight at the commit" + (begin (git/tag-lightweight! gpc "tip") (git/tag-get gpc "tip")) + gpc-c5) + +; ---- reset ---- +(git-test + "soft reset moves the branch but keeps the index" + (begin + (git/reset! gpc gpc-c4 "soft") + (list (git/head gpc) (contains? (git/diff-staged gpc) "+patched"))) + (list gpc-c4 true)) +(git-test + "mixed reset also resets the index" + (begin + (git/reset! gpc gpc-c5 "mixed") + (list (git/head gpc) (git/diff-staged gpc))) + (list gpc-c5 "")) + +; ---- detached HEAD ---- +(git-test + "detached checkout pins the cid" + (begin + (git/checkout-detached! gpc gpc-c1) + (list (git/detached? gpc) (git/head gpc))) + (list true gpc-c1)) +(git-test + "committing while detached moves only the pin" + (let + ((c6 (begin (git/add! gpc "scratch.txt" "s\n") (git/commit! gpc {:message "c6"})))) + (list (git/head gpc) (git/branch-get gpc "main"))) + (list (git/head gpc) gpc-c5)) +(git-test + "checkout! reattaches to a branch" + (begin (git/checkout! gpc "main") (git/head-target gpc)) + "heads/main") + +; ---- unstaged diff ---- +(git-test + "diff-unstaged renders worktree edits" + (contains? + (git/diff-unstaged + gpc + (assoc (git/commit-files gpc (git/head gpc)) "fix.txt" "patched\nedit\n")) + "+edit") + true) + +; ---- conflicted merge flow ---- +(define gcf (git/init! (persist/mem-backend) "cf")) +(define + gcf-c1 + (begin (git/add! gcf "f.txt" "a\nb\nc\n") (git/commit! gcf {:message "base"}))) +(define + gcf-c2 + (begin + (git/branch! gcf "left") + (git/add! gcf "f.txt" "a\nX\nc\n") + (git/commit! gcf {:message "ours"}))) +(define + gcf-c3 + (begin + (git/checkout! gcf "left") + (git/add! gcf "f.txt" "a\nY\nc\n") + (git/commit! gcf {:message "theirs"}))) +(define + gcf-m + (begin (git/checkout! gcf "main") (git/merge! gcf "left" {:message "m"}))) + +(git-test + "conflicting merge reports the paths" + (= + (list (get gcf-m :result) (get gcf-m :conflicts)) + (list "conflicts" (list "f.txt"))) + true) +(git-test + "a conflicted merge is in progress" + (git/merge-in-progress? gcf) + true) +(git-test + "the conflicted file is staged with markers" + (contains? (get (git/index-files gcf) "f.txt") "<<<<<<< ours") + true) +(git-test "HEAD did not move on conflict" (git/head gcf) gcf-c2) +(git-test + "merge-commit! concludes with two parents" + (begin + (git/add! gcf "f.txt" "a\nXY\nc\n") + (let + ((mc (git/merge-commit! gcf {:message "resolved"}))) + (= + (list + (git/head gcf) + (git/commit-parents (git/read gcf mc)) + (get (git/commit-files gcf mc) "f.txt") + (git/merge-in-progress? gcf)) + (list mc (list gcf-c2 gcf-c3) "a\nXY\nc\n" false)))) + true) +(git-test + "merge-commit! without a merge in progress errors" + (get (git/merge-commit! gcf {:message "x"}) :error) + "no merge in progress") diff --git a/lib/git/tests/ref.sx b/lib/git/tests/ref.sx new file mode 100644 index 00000000..3d42b11b --- /dev/null +++ b/lib/git/tests/ref.sx @@ -0,0 +1,208 @@ +; Phase 2 — ref: branches/tags/HEAD as name -> cid over persist kv, symbolic +; refs, CAS updates with old-value expect, reflog. + +(define grt-db (persist/mem-backend)) +(define grt (git/repo grt-db)) +(define grt-c1 (git/write-blob grt "one")) +(define grt-c2 (git/write-blob grt "two")) +(define grt-c3 (git/write-blob grt "three")) + +; ---- direct refs ---- +(git-test "ref-get on unset ref is nil" (git/ref-get grt "heads/none") nil) +(git-test + "ref-set! returns the cid" + (git/ref-set! grt "heads/main" grt-c1) + grt-c1) +(git-test "ref-get reads it back" (git/ref-get grt "heads/main") grt-c1) +(git-test + "ref-resolve on a direct ref" + (git/ref-resolve grt "heads/main") + grt-c1) +(git-test + "ref-resolve on missing ref is nil" + (git/ref-resolve grt "nope") + nil) + +; ---- symbolic refs ---- +(git-test + "symref resolves through its target" + (begin + (git/symref-set! grt "HEAD" "heads/main") + (git/ref-resolve grt "HEAD")) + grt-c1) +(git-test + "symref chain resolves" + (begin + (git/symref-set! grt "INDIRECT" "HEAD") + (git/ref-resolve grt "INDIRECT")) + grt-c1) +(git-test + "symref cycle is bounded, resolves nil" + (begin + (git/symref-set! grt "LOOPA" "LOOPB") + (git/symref-set! grt "LOOPB" "LOOPA") + (git/ref-resolve grt "LOOPA")) + nil) +(git-test "ref-get does not follow a symref" (git/ref-get grt "HEAD") nil) +(git-test + "symref? on a raw symref value" + (git/symref? (git/ref-read grt "HEAD")) + true) + +; ---- CAS ---- +(git-test + "cas create (expected nil) succeeds" + (git/ref-cas! grt "heads/dev" nil grt-c1) + grt-c1) +(git-test + "cas create conflicts when the ref exists" + (get (git/ref-cas! grt "heads/dev" nil grt-c2) :conflict) + true) +(git-test + "cas conflict reports the actual cid" + (get (git/ref-cas! grt "heads/dev" grt-c3 grt-c2) :actual) + grt-c1) +(git-test + "cas conflict leaves the ref unchanged" + (git/ref-get grt "heads/dev") + grt-c1) +(git-test + "cas with the right expected value moves the ref" + (git/ref-cas! grt "heads/dev" grt-c1 grt-c2) + grt-c2) +(git-test "cas move is visible" (git/ref-get grt "heads/dev") grt-c2) + +; ---- delete ---- +(git-test + "ref-delete! removes the ref" + (begin + (git/ref-set! grt "heads/tmp" grt-c1) + (git/ref-delete! grt "heads/tmp") + (git/ref-get grt "heads/tmp")) + nil) + +; ---- branch conveniences ---- +(git-test + "branch-create! returns the cid" + (git/branch-create! grt "feature" grt-c1) + grt-c1) +(git-test + "branch-create! conflicts on an existing branch" + (get (git/branch-create! grt "feature" grt-c2) :conflict) + true) +(git-test "branch-get" (git/branch-get grt "feature") grt-c1) +(git-test + "branch-cas! moves the branch" + (git/branch-cas! grt "feature" grt-c1 grt-c2) + grt-c2) +(git-test + "branch-set! moves unconditionally" + (git/branch-set! grt "feature" grt-c3) + grt-c3) +(git-test + "branch-delete! removes it" + (begin (git/branch-delete! grt "feature") (git/branch-get grt "feature")) + nil) + +; ---- listing ---- +(git-test + "branches are listed sorted, tags and HEAD excluded" + (let + ((db (persist/mem-backend))) + (let + ((r (git/repo db))) + (begin + (git/branch-set! r "zeta" "sx1:z") + (git/branch-set! r "alpha" "sx1:a") + (git/tag-set! r "v1" "sx1:t") + (git/head-set! r "alpha") + (= (git/branches r) (list "alpha" "zeta"))))) + true) +(git-test + "tag-names lists tag refs" + (let + ((db (persist/mem-backend))) + (let + ((r (git/repo db))) + (begin + (git/tag-set! r "v2" "sx1:t2") + (git/tag-set! r "v1" "sx1:t1") + (= (git/tag-names r) (list "v1" "v2"))))) + true) +(git-test + "tag-get reads a tag ref" + (begin (git/tag-set! grt "v1" grt-c1) (git/tag-get grt "v1")) + grt-c1) + +; ---- HEAD ---- +(git-test + "head resolves through the current branch" + (begin + (git/branch-set! grt "main" grt-c2) + (git/head-set! grt "main") + (git/head grt)) + grt-c2) +(git-test + "moving the branch moves head" + (begin (git/branch-set! grt "main" grt-c3) (git/head grt)) + grt-c3) +(git-test + "head-target names the branch ref" + (git/head-target grt) + "heads/main") +(git-test "detached? false on a symref HEAD" (git/detached? grt) false) +(git-test + "head-detach! pins a cid" + (begin (git/head-detach! grt grt-c1) (git/head grt)) + grt-c1) +(git-test "detached? true after detach" (git/detached? grt) true) +(git-test "head-target nil when detached" (git/head-target grt) nil) + +; ---- reflog ---- +(git-test + "reflog of an untouched ref is empty" + (= (git/reflog grt "heads/quiet") (list)) + true) +(git-test + "reflog records create and moves oldest-first" + (let + ((db (persist/mem-backend))) + (let + ((r (git/repo db))) + (begin + (git/ref-set! r "heads/x" "sx1:a") + (git/ref-set! r "heads/x" "sx1:b") + (git/ref-cas! r "heads/x" "sx1:b" "sx1:c") + (= (git/reflog r "heads/x") (list {:new "sx1:a" :old nil} {:new "sx1:b" :old "sx1:a"} {:new "sx1:c" :old "sx1:b"}))))) + true) +(git-test + "branch-create! writes the first reflog entry" + (let + ((db (persist/mem-backend))) + (let + ((r (git/repo db))) + (begin + (git/branch-create! r "b" "sx1:a") + (= (git/reflog r "heads/b") (list {:new "sx1:a" :old nil}))))) + true) +(git-test + "failed cas leaves no reflog entry" + (let + ((db (persist/mem-backend))) + (let + ((r (git/repo db))) + (begin + (git/ref-set! r "heads/x" "sx1:a") + (git/ref-cas! r "heads/x" "sx1:wrong" "sx1:b") + (len (git/reflog r "heads/x"))))) + 1) + +; ---- namespacing ---- +(git-test + "refs are invisible across repo namespaces" + (let + ((db (persist/mem-backend))) + (begin + (git/branch-set! (git/repo-named db "a") "main" "sx1:a") + (git/branch-get (git/repo-named db "b") "main"))) + nil) diff --git a/lib/git/tests/worktree.sx b/lib/git/tests/worktree.sx new file mode 100644 index 00000000..2007307a --- /dev/null +++ b/lib/git/tests/worktree.sx @@ -0,0 +1,253 @@ +; Phase 4 — worktree: tree materialization (files-dict <-> tree objects), +; index as staged-tree overlay, three-way status. + +(define gwt-db (persist/mem-backend)) +(define gwt (git/repo gwt-db)) + +(define + gwt-files + (assoc + (assoc (assoc {} "a.txt" "hello\n") "b.txt" "world\n") + "sub/c.txt" + "sub\n")) + +(define gwt-tree (git/tree-from-files gwt gwt-files)) +(define gwt-c1 (git/write gwt (git/commit gwt-tree (list) {:message "c1"}))) + +; fresh repo with the fixture committed, HEAD on main, index clean +(define + gwt-fresh! + (fn + () + (let + ((r (git/repo (persist/mem-backend)))) + (let + ((tc (git/tree-from-files r gwt-files))) + (let + ((c (git/write r (git/commit tc (list) {:message "c1"})))) + (begin + (git/branch-set! r "main" c) + (git/head-set! r "main") + (git/index-init! r c) + r)))))) + +(define gwt-clean {:untracked (list) :staged {:deleted (list) :modified (list) :added (list)} :unstaged {:deleted (list) :modified (list)}}) + +; ---- tree building + materialization ---- +(git-test + "tree-from-files writes a tree object" + (git/tree? (git/read gwt gwt-tree)) + true) +(git-test + "tree-files round-trips the files dict" + (= (git/tree-files gwt gwt-tree) gwt-files) + true) +(git-test + "tree-from-files is deterministic" + (equal? (git/tree-from-files gwt gwt-files) gwt-tree) + true) +(git-test + "matches a manually built tree" + (equal? + (git/write + gwt + (git/tree + (assoc + (assoc + (assoc + {} + "a.txt" + (git/tree-entry "blob" (git/write-blob gwt "hello\n"))) + "b.txt" + (git/tree-entry "blob" (git/write-blob gwt "world\n"))) + "sub" + (git/tree-entry + "tree" + (git/write + gwt + (git/tree + (assoc + {} + "c.txt" + (git/tree-entry "blob" (git/write-blob gwt "sub\n"))))))))) + gwt-tree) + true) +(git-test + "flatten lists nested paths" + (= + (artdag/sort-strings (keys (git/tree-flatten gwt gwt-tree))) + (list "a.txt" "b.txt" "sub/c.txt")) + true) +(git-test + "flatten maps a path to its blob cid" + (get (git/tree-flatten gwt gwt-tree) "a.txt") + (git/cid (git/blob "hello\n"))) +(git-test + "commit-files materializes through the commit" + (= (git/commit-files gwt gwt-c1) gwt-files) + true) +(git-test + "deep nesting round-trips" + (let + ((files (assoc {} "x/y/z.txt" "deep"))) + (= (git/tree-files gwt (git/tree-from-files gwt files)) files)) + true) +(git-test + "empty files dict is an empty tree" + (= (git/tree-files gwt (git/tree-from-files gwt {})) {}) + true) + +; ---- index ---- +(git-test + "default index is empty over no base" + (= (git/index-read (git/repo (persist/mem-backend))) {:base nil :staged {}}) + true) +(git-test + "index-init! bases the index on the commit tree" + (let ((r (gwt-fresh!))) (= (git/index-files r) gwt-files)) + true) +(git-test + "add! stages new content" + (let + ((r (gwt-fresh!))) + (begin + (git/add! r "new.txt" "fresh") + (get (git/index-files r) "new.txt"))) + "fresh") +(git-test + "add! overlays an existing path" + (let + ((r (gwt-fresh!))) + (begin (git/add! r "a.txt" "changed") (get (git/index-files r) "a.txt"))) + "changed") +(git-test + "rm! stages a removal" + (let + ((r (gwt-fresh!))) + (begin (git/rm! r "b.txt") (has-key? (git/index-files r) "b.txt"))) + false) +(git-test + "unstage! reverts to the base" + (let + ((r (gwt-fresh!))) + (begin + (git/add! r "a.txt" "changed") + (git/unstage! r "a.txt") + (get (git/index-files r) "a.txt"))) + "hello\n") +(git-test + "index-tree! of a clean index reproduces the commit tree cid" + (let + ((r (gwt-fresh!))) + (equal? + (git/index-tree! r) + (git/commit-tree (git/read r (git/head r))))) + true) +(git-test + "index-tree! materializes staged changes" + (let + ((r (gwt-fresh!))) + (begin + (git/add! r "a.txt" "changed") + (git/rm! r "b.txt") + (= + (git/tree-files r (git/index-tree! r)) + (assoc (assoc {} "a.txt" "changed") "sub/c.txt" "sub\n")))) + true) + +; ---- status ---- +(git-test + "clean repo, clean worktree" + (= (git/status (gwt-fresh!) gwt-files) gwt-clean) + true) +(git-test + "staged addition" + (let + ((r (gwt-fresh!))) + (begin + (git/add! r "new.txt" "fresh") + (= + (get (get (git/status r gwt-files) :staged) :added) + (list "new.txt")))) + true) +(git-test + "staged modification" + (let + ((r (gwt-fresh!))) + (begin + (git/add! r "a.txt" "changed") + (= + (get + (get (git/status r (assoc gwt-files "a.txt" "changed")) :staged) + :modified) + (list "a.txt")))) + true) +(git-test + "staged deletion" + (let + ((r (gwt-fresh!))) + (begin + (git/rm! r "b.txt") + (= + (get + (get (git/status r (dissoc gwt-files "b.txt")) :staged) + :deleted) + (list "b.txt")))) + true) +(git-test + "unstaged modification" + (let + ((r (gwt-fresh!))) + (= + (get + (get (git/status r (assoc gwt-files "a.txt" "edited")) :unstaged) + :modified) + (list "a.txt"))) + true) +(git-test + "unstaged deletion" + (let + ((r (gwt-fresh!))) + (= + (get + (get (git/status r (dissoc gwt-files "sub/c.txt")) :unstaged) + :deleted) + (list "sub/c.txt"))) + true) +(git-test + "untracked file" + (let + ((r (gwt-fresh!))) + (= + (get (git/status r (assoc gwt-files "notes.md" "hi")) :untracked) + (list "notes.md"))) + true) +(git-test + "combined status" + (let + ((r (gwt-fresh!))) + (begin + (git/add! r "staged.txt" "s") + (git/add! r "a.txt" "changed") + (git/rm! r "b.txt") + (= + (git/status + r + (assoc + (assoc + (assoc + (dissoc (dissoc gwt-files "b.txt") "sub/c.txt") + "a.txt" + "changed-again") + "staged.txt" + "s") + "wild.txt" + "w")) + {:untracked (list "wild.txt") :staged {:deleted (list "b.txt") :modified (list "a.txt") :added (list "staged.txt")} :unstaged {:deleted (list "sub/c.txt") :modified (list "a.txt")}}))) + true) +(git-test + "no HEAD, no index: everything untracked" + (let + ((r (git/repo (persist/mem-backend)))) + (= (git/status r (assoc {} "f.txt" "x")) {:untracked (list "f.txt") :staged {:deleted (list) :modified (list) :added (list)} :unstaged {:deleted (list) :modified (list)}})) + true) diff --git a/lib/git/worktree.sx b/lib/git/worktree.sx new file mode 100644 index 00000000..7a13c639 --- /dev/null +++ b/lib/git/worktree.sx @@ -0,0 +1,234 @@ +; lib/git/worktree.sx — sx-git Phase 4: tree materialization, index, status. +; The "worktree" is a VALUE: a dict of path -> file data (no filesystem). +; The index is a staged-tree overlay {:base :staged +; {path -> {:data d} | {:removed true}}} stored in kv at /index. +; status = three-way dict diff: HEAD tree vs index vs worktree. +; Requires: lib/git/object.sx, lib/git/ref.sx. + +(define + git/wt-join + (fn + (segs) + (if + (empty? segs) + "" + (reduce (fn (acc s) (str acc "/" s)) (first segs) (rest segs))))) + +; ---- tree flattening: tree-cid -> dict path -> blob cid ---- +(define + git/wt-flatten-into + (fn + (repo tree-cid prefix acc) + (let + ((tree (git/read repo tree-cid))) + (reduce + (fn + (a name) + (let + ((e (git/tree-entry-for tree name))) + (let + ((path (if (equal? prefix "") name (str prefix "/" name)))) + (if + (equal? (git/entry-kind e) "tree") + (git/wt-flatten-into repo (git/entry-cid e) path a) + (assoc a path (git/entry-cid e)))))) + acc + (git/tree-names tree))))) + +(define + git/tree-flatten + (fn (repo tree-cid) (git/wt-flatten-into repo tree-cid "" {}))) + +; ---- materialization: tree/commit -> dict path -> data ---- +(define + git/tree-files + (fn + (repo tree-cid) + (let + ((flat (git/tree-flatten repo tree-cid))) + (reduce + (fn + (a p) + (assoc a p (git/blob-data (git/read repo (get flat p))))) + {} + (keys flat))))) + +(define + git/commit-files + (fn + (repo commit-cid) + (git/tree-files repo (git/commit-tree (git/read repo commit-cid))))) + +; ---- inverse: dict path -> data => written tree, returns root tree cid ---- +(define + git/wt-group + (fn + (files) + (reduce + (fn + (acc path) + (let + ((segs (split path "/"))) + (if + (= (len segs) 1) + (assoc + acc + :files (assoc (get acc :files) path (get files path))) + (let + ((dir (first segs))) + (let + ((cur (get (get acc :dirs) dir))) + (assoc + acc + :dirs (assoc + (get acc :dirs) + dir + (assoc + (if (dict? cur) cur {}) + (git/wt-join (rest segs)) + (get files path))))))))) + {:files {} :dirs {}} + (keys files)))) + +(define + git/tree-from-files + (fn + (repo files) + (let + ((g (git/wt-group files))) + (let + ((with-blobs (reduce (fn (acc name) (assoc acc name (git/tree-entry "blob" (git/write-blob repo (get (get g :files) name))))) {} (keys (get g :files))))) + (let + ((entries (reduce (fn (acc dir) (assoc acc dir (git/tree-entry "tree" (git/tree-from-files repo (get (get g :dirs) dir))))) with-blobs (keys (get g :dirs))))) + (git/write repo (git/tree entries))))))) + +; ---- index: staged overlay over a base tree ---- +(define git/index-key (fn (repo) (str (get repo :prefix) "/index"))) + +(define + git/index-read + (fn + (repo) + (let + ((v (persist/kv-get (get repo :db) (git/index-key repo)))) + (if (dict? v) v {:base nil :staged {}})))) + +(define + git/index-write! + (fn + (repo idx) + (begin (persist/kv-put (get repo :db) (git/index-key repo) idx) idx))) + +; reset the index to a commit's tree (nil commit = empty index) +(define + git/index-init! + (fn (repo commit-cid) (git/index-write! repo {:base (if (equal? commit-cid nil) nil (git/commit-tree (git/read repo commit-cid))) :staged {}}))) + +(define + git/wt-stage! + (fn + (repo path entry) + (let + ((idx (git/index-read repo))) + (git/index-write! + repo + (assoc idx :staged (assoc (get idx :staged) path entry)))))) + +(define git/add! (fn (repo path data) (git/wt-stage! repo path {:data data}))) +(define git/rm! (fn (repo path) (git/wt-stage! repo path {:removed true}))) + +(define + git/unstage! + (fn + (repo path) + (let + ((idx (git/index-read repo))) + (git/index-write! + repo + (assoc idx :staged (dissoc (get idx :staged) path)))))) + +; apply the overlay: base entries -> overridden/removed by staged +(define + git/wt-overlay + (fn + (base staged entry-fn) + (reduce + (fn + (acc path) + (let + ((s (get staged path))) + (if + (has-key? s :removed) + (dissoc acc path) + (assoc acc path (entry-fn s))))) + base + (keys staged)))) + +; effective index as path -> blob cid +(define + git/index-cids + (fn + (repo) + (let + ((idx (git/index-read repo))) + (git/wt-overlay + (if + (equal? (get idx :base) nil) + {} + (git/tree-flatten repo (get idx :base))) + (get idx :staged) + (fn (s) (git/cid (git/blob (get s :data)))))))) + +; effective index as path -> data +(define + git/index-files + (fn + (repo) + (let + ((idx (git/index-read repo))) + (git/wt-overlay + (if + (equal? (get idx :base) nil) + {} + (git/tree-files repo (get idx :base))) + (get idx :staged) + (fn (s) (get s :data)))))) + +; write the staged state as a real tree; returns the root tree cid +(define + git/index-tree! + (fn (repo) (git/tree-from-files repo (git/index-files repo)))) + +; ---- status ---- +(define + git/files-cids + (fn + (files) + (reduce + (fn (acc p) (assoc acc p (git/cid (git/blob (get files p))))) + {} + (keys files)))) + +(define git/files-diff (fn (old new) {:deleted (artdag/sort-strings (filter (fn (p) (not (has-key? new p))) (keys old))) :modified (artdag/sort-strings (filter (fn (p) (and (has-key? old p) (not (equal? (get old p) (get new p))))) (keys new))) :added (artdag/sort-strings (filter (fn (p) (not (has-key? old p))) (keys new)))})) + +(define + git/head-tree-cids + (fn + (repo) + (let + ((h (git/head repo))) + (if + (equal? h nil) + {} + (git/tree-flatten repo (git/commit-tree (git/read repo h))))))) + +; worktree-files: dict path -> data (the caller's working copy value) +(define + git/status + (fn + (repo worktree-files) + (let + ((headc (git/head-tree-cids repo)) + (idxc (git/index-cids repo)) + (wtc (git/files-cids worktree-files))) + (let ((unstaged (git/files-diff idxc wtc))) {:untracked (get unstaged :added) :staged (git/files-diff headc idxc) :unstaged {:deleted (get unstaged :deleted) :modified (get unstaged :modified)}})))) diff --git a/lib/gitea/README.md b/lib/gitea/README.md new file mode 100644 index 00000000..ab29f827 --- /dev/null +++ b/lib/gitea/README.md @@ -0,0 +1,61 @@ +# sx-gitea — a federated git forge in plain SX + +A git forge built by **composing the x-on-sx subsystems**: every phase +wires one more substrate onto the forge. No third-party dependencies — +the whole stack is SX on the OCaml kernel. + +Run the suite: `bash lib/gitea/conformance.sh` (per-suite scores in +`scoreboard.md`). Suites are independent `sx_server` sessions; heavyweight +substrates (Smalltalk/content, Scheme/flow, APL/feed, Haskell/search) load +only for the suites that need them. + +## Composition map + +| Phase | Module | Built on | +|-------|--------|----------| +| 1 repo | `repo.sx` | **sx-git** (`lib/git`, native-CID object store), persist kv | +| 2 access | `access.sx` | **acl** (datalog): repo role groups, collaborators, org teams; bearer tokens | +| 3 wire | `wire.sx` | git-style smart HTTP: pkt-line framing, upload/receive-pack, CID-verified packs; client (`clone!`/`fetch!`/`push!`) drives any dream app fn | +| 4 issues | `issues.sx` | **content** (Smalltalk): Markdown bodies as block documents; **relations** (datalog): derived issue graph | +| 5 pr | `pr.sx` | **sx-git** merge-base diffs + 3-way merge; **flow** (Scheme): durable open→approval→merge lifecycle; merge queue | +| 6 activity | `activity.sx` | **feed** (APL): timelines/dashboard; **events** (flow): durable at-least-once notifications | +| 7 search | `search.sx` | **search** (Haskell): tf-idf ranked code/issue/PR search, batched evaluations | +| 8 fed | `fed.sx` | ForgeFed: AP actors, trust-gated inbox with provenance + materialized federated issues/PRs, mirrors over the wire client, cursor-based delivery | +| web | `web.sx` | **dream**: routes, auth gating (401/403/404-hides-private), route-pack registry | + +## Architectural rules of thumb + +- **The kv store is the source of truth.** Owners, repo records, issues, + PRs, collaborators, teams, tokens, follows, trust, mirrors — all plain + dicts under `gitea/...` keys on one persist backend per forge. + Deleting a repo is a prefix purge (no ghost state on recreate). +- **Derived, not maintained.** The acl database and the relations graph + are *derived* from kv state and rebuilt when the derived facts change + (cached in the forge handle) — deletions can never dangle. +- **Instrument in the runtime.** Activity logging wraps the mutation + verbs by redefinition (`gitea/base-*!` + wrapper), so every caller + emits activity with zero call-site edits. +- **Everything is testable without sockets.** A forge is a value over a + `persist/mem-backend`; `gitea/app` is a pure request→response fn; the + wire client federates two in-memory forges directly. +- **Trust is re-checked, never cached.** Federation operations + (inbox, mirror sync, delivery) consult the trust set at use time. + +## Per-repo git stores + +Each repo's objects/refs live in their own `git/repo-named` namespace +`forge//` — identical content still shares CIDs, but repos +cannot see each other's objects. All ref moves go through `ref-cas!`; +concurrent pushes surface as `stale`/`non-fast-forward` per-ref statuses. + +## Known limits (deliberate, documented) + +- Wire packs carry one object per pkt line (~64KB); side-band chunking + is a future extension (`gitea/pkt-fits?` reports it). SHA-1/packfile + byte compat for stock git clients lives in `lib/git/{export,import}.sx` + and is not yet wired into the HTTP endpoints. +- Inbox activities are trust-gated but not signature-verified. +- Reopening a PR restarts its lifecycle flow (a cancelled flow cannot + resume); reviews survive. +- Issue web close/reopen does not emit activity (no actor at the core + call sites for `issue-close!`). diff --git a/lib/gitea/access.sx b/lib/gitea/access.sx new file mode 100644 index 00000000..c2bc45aa --- /dev/null +++ b/lib/gitea/access.sx @@ -0,0 +1,403 @@ +; lib/gitea/access.sx — sx-gitea Phase 2: permissions over lib/acl. +; +; Model: each repo exposes three role groups ("read:"/"write:"/"admin:" + +; "repo:/") with hierarchical action grants (admin > write > +; read). A user-owner is a member of the admin group. Collaborators join +; the group for their role. Org repos add team groups: a team has a role +; and a repo scope ("all" or a name list); team members join the team +; group, the team group joins the covered repos' role groups. Facts are +; derived from forge state and saturated by the acl datalog engine — +; deny-wins and group nesting come for free. +; +; Public visibility is an engine short-circuit: "read" on a public repo is +; always permitted, even anonymously (subject nil never reaches acl). +; +; Auth is bearer tokens in the kv store — Phase 8 federates identity. +; +; Requires: lib/gitea/repo.sx, lib/datalog/* stack, +; lib/acl/{schema,facts,engine}.sx + +(define gitea/roles (list "read" "write" "admin")) +(define gitea/role-valid? (fn (r) (contains? gitea/roles r))) + +; actions implied by holding a role on a repo +(define + gitea/role-actions + (fn + (role) + (cond + ((equal? role "read") (list "read")) + ((equal? role "write") (list "read" "write")) + ((equal? role "admin") (list "read" "write" "admin")) + (else (list))))) + +(define gitea/repo-res (fn (owner name) (str "repo:" owner "/" name))) +(define gitea/role-group (fn (res role) (str role ":" res))) +(define gitea/team-id (fn (org team) (str "team:" org "/" team))) + +(define + gitea/split-full + (fn (full) (let ((i (index-of full "/"))) {:name (substr full (+ i 1)) :owner (substr full 0 i)}))) + +; ── collaborators ──────────────────────────────────────────────────── + +(define + gitea/collab-key + (fn (owner name user) (str "gitea/collab/" owner "/" name "/" user))) + +; upsert: adding an existing collaborator changes their role +(define + gitea/collab-add! + (fn + (forge owner name user role) + (cond + ((not (gitea/repo-exists? forge owner name)) {:error "no-such-repo"}) + ((not (gitea/owner-exists? forge user)) {:error "no-such-user"}) + ((not (gitea/role-valid? role)) {:error "invalid-role"}) + (else + (persist/kv-put + (gitea/forge-db forge) + (gitea/collab-key owner name user) + {:role role :user user}))))) + +(define + gitea/collab-get + (fn + (forge owner name user) + (persist/kv-get + (gitea/forge-db forge) + (gitea/collab-key owner name user)))) + +(define + gitea/collab-role + (fn + (forge owner name user) + (get (or (gitea/collab-get forge owner name user) {}) :role))) + +(define + gitea/collab-remove! + (fn + (forge owner name user) + (if + (nil? (gitea/collab-get forge owner name user)) + false + (begin + (persist/kv-delete + (gitea/forge-db forge) + (gitea/collab-key owner name user)) + true)))) + +(define + gitea/collabs + (fn + (forge owner name) + (gitea/names-under forge (str "gitea/collab/" owner "/" name "/")))) + +; ── teams ──────────────────────────────────────────────────────────── +; A team belongs to an org, carries ONE role, and covers either every org +; repo (:repos "all") or an explicit list of repo names. + +(define gitea/team-key (fn (org team) (str "gitea/team/" org "/" team))) +(define + gitea/teammem-key + (fn (org team user) (str "gitea/teammem/" org "/" team "/" user))) + +(define + gitea/team-create! + (fn + (forge org team role) + (let + ((orec (gitea/owner-get forge org))) + (cond + ((or (nil? orec) (not (gitea/org? orec))) {:error "no-such-org"}) + ((not (gitea/valid-name? team)) {:error "invalid-name"}) + ((not (gitea/role-valid? role)) {:error "invalid-role"}) + (else + (persist/kv-put-new + (gitea/forge-db forge) + (gitea/team-key org team) + {:name team :org org :repos "all" :role role})))))) + +(define + gitea/team-get + (fn + (forge org team) + (persist/kv-get (gitea/forge-db forge) (gitea/team-key org team)))) + +(define + gitea/teams + (fn (forge org) (gitea/names-under forge (str "gitea/team/" org "/")))) + +(define + gitea/team-set-repos! + (fn + (forge org team repos) + (let + ((rec (gitea/team-get forge org team))) + (if + (nil? rec) + nil + (persist/kv-put + (gitea/forge-db forge) + (gitea/team-key org team) + (assoc rec :repos repos)))))) + +(define + gitea/team-add-member! + (fn + (forge org team user) + (cond + ((nil? (gitea/team-get forge org team)) {:error "no-such-team"}) + ((not (gitea/owner-exists? forge user)) {:error "no-such-user"}) + (else + (persist/kv-put + (gitea/forge-db forge) + (gitea/teammem-key org team user) + {:user user}))))) + +(define + gitea/team-remove-member! + (fn + (forge org team user) + (let + ((k (gitea/teammem-key org team user))) + (if + (persist/kv-has? (gitea/forge-db forge) k) + (begin (persist/kv-delete (gitea/forge-db forge) k) true) + false)))) + +(define + gitea/team-members + (fn + (forge org team) + (gitea/names-under forge (str "gitea/teammem/" org "/" team "/")))) + +(define + gitea/team-delete! + (fn + (forge org team) + (if + (nil? (gitea/team-get forge org team)) + false + (let + ((db (gitea/forge-db forge))) + (begin + (for-each + (fn (u) (persist/kv-delete db (gitea/teammem-key org team u))) + (gitea/team-members forge org team)) + (persist/kv-delete db (gitea/team-key org team)) + true))))) + +(define + gitea/team-covers? + (fn + (trec name) + (let + ((repos (get trec :repos))) + (or (equal? repos "all") (and (list? repos) (contains? repos name)))))) + +; org admin = member of an admin-role team that covers every repo +(define + gitea/org-admin? + (fn + (forge org user) + (reduce + (fn + (acc tname) + (or + acc + (let + ((trec (gitea/team-get forge org tname))) + (and + (equal? (get trec :role) "admin") + (equal? (get trec :repos) "all") + (contains? (gitea/team-members forge org tname) user))))) + false + (gitea/teams forge org)))) + +; ── acl fact derivation ────────────────────────────────────────────── + +(define + gitea/access-facts + (fn + (forge) + (let + ((facts (list))) + (begin + (for-each + (fn + (full) + (let + ((p (gitea/split-full full))) + (let + ((owner (get p :owner)) (name (get p :name))) + (let + ((res (gitea/repo-res owner name)) + (orec (gitea/owner-get forge owner))) + (begin + (for-each + (fn + (role) + (for-each + (fn + (act) + (append! + facts + (acl-grant (gitea/role-group res role) act res))) + (gitea/role-actions role))) + gitea/roles) + (if + (and orec (gitea/user? orec)) + (append! + facts + (acl-member-of owner (gitea/role-group res "admin"))) + nil) + (for-each + (fn + (user) + (append! + facts + (acl-member-of + user + (gitea/role-group + res + (gitea/collab-role forge owner name user))))) + (gitea/collabs forge owner name)) + (if + (and orec (gitea/org? orec)) + (for-each + (fn + (tname) + (let + ((trec (gitea/team-get forge owner tname))) + (if + (gitea/team-covers? trec name) + (append! + facts + (acl-member-of + (gitea/team-id owner tname) + (gitea/role-group res (get trec :role)))) + nil))) + (gitea/teams forge owner)) + nil)))))) + (gitea/repos forge)) + (for-each + (fn + (owner) + (let + ((orec (gitea/owner-get forge owner))) + (if + (and orec (gitea/org? orec)) + (for-each + (fn + (tname) + (for-each + (fn + (user) + (append! + facts + (acl-member-of user (gitea/team-id owner tname)))) + (gitea/team-members forge owner tname))) + (gitea/teams forge owner)) + nil))) + (gitea/owners forge)) + facts)))) + +; rebuild the acl db only when derived facts changed (cache in the forge +; handle; forges created before the :cache field just rebuild every call) +(define + gitea/access-db + (fn + (forge) + (let + ((facts (gitea/access-facts forge)) (cache (get forge :cache))) + (if + (and cache (= (get cache "facts") facts) (get cache "db")) + (get cache "db") + (let + ((db (acl-build-db facts))) + (begin + (if + cache + (begin + (dict-set! cache "facts" facts) + (dict-set! cache "db" db)) + nil) + db)))))) + +; ── the permission question ────────────────────────────────────────── + +(define + gitea/can? + (fn + (forge subj action owner name) + (let + ((rec (gitea/repo-get forge owner name))) + (cond + ((nil? rec) false) + ((and (equal? action "read") (equal? (get rec :visibility) "public")) + true) + ((nil? subj) false) + (else + (acl-permit? + (gitea/access-db forge) + subj + action + (gitea/repo-res owner name))))))) + +(define + gitea/visible-repos + (fn + (forge subj) + (filter + (fn + (full) + (let + ((p (gitea/split-full full))) + (gitea/can? forge subj "read" (get p :owner) (get p :name)))) + (gitea/repos forge)))) + +; who may create a repo under this owner? +(define + gitea/create-allowed? + (fn + (forge user owner) + (let + ((orec (gitea/owner-get forge owner))) + (cond + ((nil? user) false) + ((nil? orec) false) + ((gitea/user? orec) (equal? user owner)) + (else (gitea/org-admin? forge owner user)))))) + +; ── bearer tokens ──────────────────────────────────────────────────── + +(define gitea/token-key (fn (token) (str "gitea/token/" token))) + +(define + gitea/token-create! + (fn + (forge user token) + (if + (not (gitea/owner-exists? forge user)) + {:error "no-such-user"} + (persist/kv-put + (gitea/forge-db forge) + (gitea/token-key token) + {:user user})))) + +(define + gitea/token-user + (fn + (forge token) + (get + (or + (persist/kv-get (gitea/forge-db forge) (gitea/token-key token)) + {}) + :user))) + +(define + gitea/token-revoke! + (fn + (forge token) + (persist/kv-delete (gitea/forge-db forge) (gitea/token-key token)))) diff --git a/lib/gitea/activity.sx b/lib/gitea/activity.sx new file mode 100644 index 00000000..dd57cbd5 --- /dev/null +++ b/lib/gitea/activity.sx @@ -0,0 +1,579 @@ +; lib/gitea/activity.sx — sx-gitea Phase 6: activity, dashboard, notify. +; +; Every noteworthy forge action lands as a feed activity ({:actor :verb +; :object :at :tags}) in an append-only persist log stream on the forge +; backend. Instrumentation wraps the existing mutation verbs IN the +; runtime (repo-create!/issue-create!/issue-comment!/pr-create!/ +; pr-review!/pr-merge! are redefined around their originals), so SX +; callers and web handlers alike emit activity with zero call-site edits. +; +; Timelines are lib/feed queries over that stream (APL-backed filter/ +; rank/take); visibility follows repo access — an activity tagged with a +; private repo is invisible to non-readers. The dashboard shows what a +; user follows (users or repos), minus their own actions. +; +; Notifications ride lib/events' durable delivery flows: pending +; activities after a cursor expand to (id recipient body) messages, +; ev/deliver-messages runs them through the at-least-once digest flow +; (idempotent by message id), and delivered messages land in per-user kv +; inboxes; the cursor then advances, so a re-run delivers nothing twice. +; +; Requires: lib/gitea/{repo,access,web,issues,pr}.sx and their stacks, +; lib/apl/runtime.sx + lib/feed/{normalize,stream,api,fanout,dedupe, +; aggregate,rank,acl,mute,page,notify,home,fed}.sx, and +; lib/events/notify.sx over the flow stack. + +; ── the activity log ───────────────────────────────────────────────── + +(define gitea/activity-stream-name "gitea/activity") + +(define + gitea/act! + (fn + (forge actor verb object tags at) + (persist/append + (gitea/forge-db forge) + gitea/activity-stream-name + verb + at + (feed/activity actor verb object at tags)))) + +(define + gitea/activity-events + (fn + (forge) + (persist/read (gitea/forge-db forge) gitea/activity-stream-name))) + +(define + gitea/activity-stream + (fn + (forge) + (feed/stream (map persist/event-data (gitea/activity-events forge))))) + +(define + gitea/activity-count + (fn + (forge) + (persist/last-seq (gitea/forge-db forge) gitea/activity-stream-name))) + +; ── node helpers ───────────────────────────────────────────────────── + +(define gitea/pr-node (fn (owner name n) (str "pr:" owner "/" name "#" n))) + +; "issue:alice/proj#3" / "pr:alice/proj#3" => {:owner :name :n} | nil +(define + gitea/parse-numbered-node + (fn + (node) + (let + ((colon (index-of node ":")) (hash (index-of node "#"))) + (if + (or (< colon 0) (< hash 0)) + nil + (let + ((p (gitea/split-full (substr node (+ colon 1) (- hash colon 1))))) + {:name (get p :name) :n (parse-int (substr node (+ hash 1))) :owner (get p :owner)}))))) + +; the repo an activity belongs to, via its tags +(define + gitea/act-repo + (fn + (a) + (first (filter (fn (t) (starts-with? t "repo:")) (get a :tags))))) + +(define + gitea/act-visible? + (fn + (forge user a) + (let + ((r (gitea/act-repo a))) + (if + (nil? r) + true + (let + ((p (gitea/split-full (substr r 5)))) + (gitea/can? forge user "read" (get p :owner) (get p :name))))))) + +; ── instrumentation: wrap the mutation verbs ───────────────────────── + +(define gitea/base-repo-create! gitea/repo-create!) +(define + gitea/repo-create! + (fn + (forge owner name opts) + (let + ((res (gitea/base-repo-create! forge owner name opts))) + (begin + (if + (or (get res :error) (get res :conflict)) + nil + (gitea/act! + forge + owner + "create-repo" + (gitea/repo-node owner name) + (list (gitea/repo-node owner name)) + (get res :created-at))) + res)))) + +(define gitea/base-issue-create! gitea/issue-create!) +(define + gitea/issue-create! + (fn + (forge owner name author title body opts) + (let + ((res (gitea/base-issue-create! forge owner name author title body opts))) + (begin + (if + (get res :error) + nil + (gitea/act! + forge + author + "open-issue" + (gitea/issue-node owner name (get res :number)) + (list (gitea/repo-node owner name)) + (get res :created-at))) + res)))) + +(define gitea/base-issue-comment! gitea/issue-comment!) +(define + gitea/issue-comment! + (fn + (forge owner name n author body opts) + (let + ((res (gitea/base-issue-comment! forge owner name n author body opts))) + (begin + (if + (get res :error) + nil + (gitea/act! + forge + author + "comment" + (gitea/issue-node owner name n) + (list (gitea/repo-node owner name)) + (get res :at))) + res)))) + +(define gitea/base-pr-create! gitea/pr-create!) +(define + gitea/pr-create! + (fn + (forge owner name author title source target body opts) + (let + ((res (gitea/base-pr-create! forge owner name author title source target body opts))) + (begin + (if + (get res :error) + nil + (gitea/act! + forge + author + "open-pr" + (gitea/pr-node owner name (get res :number)) + (list (gitea/repo-node owner name)) + (get res :created-at))) + res)))) + +(define gitea/base-pr-review! gitea/pr-review!) +(define + gitea/pr-review! + (fn + (forge owner name n reviewer verdict body opts) + (let + ((res (gitea/base-pr-review! forge owner name n reviewer verdict body opts))) + (begin + (if + (get res :error) + nil + (gitea/act! + forge + reviewer + "review" + (gitea/pr-node owner name n) + (list (gitea/repo-node owner name)) + (get res :at))) + res)))) + +(define gitea/base-pr-merge! gitea/pr-merge!) +(define + gitea/pr-merge! + (fn + (forge owner name n merger opts) + (let + ((res (gitea/base-pr-merge! forge owner name n merger opts))) + (begin + (if + (get res :error) + nil + (gitea/act! + forge + merger + "merge-pr" + (gitea/pr-node owner name n) + (list (gitea/repo-node owner name)) + (or (get (or opts {}) :time) 0))) + res)))) + +; ── timelines ──────────────────────────────────────────────────────── + +(define + gitea/timeline + (fn + (forge user n) + (feed/items + (feed/take + (feed/recent + (feed/filter + (gitea/activity-stream forge) + (fn (a) (gitea/act-visible? forge user a)))) + n)))) + +(define + gitea/repo-timeline + (fn + (forge owner name n) + (let + ((node (gitea/repo-node owner name))) + (feed/items + (feed/take + (feed/recent + (feed/filter + (gitea/activity-stream forge) + (fn (a) (contains? (get a :tags) node)))) + n))))) + +(define + gitea/user-timeline + (fn + (forge viewer user n) + (feed/items + (feed/take + (feed/recent + (feed/filter + (feed/by-actor (gitea/activity-stream forge) user) + (fn (a) (gitea/act-visible? forge viewer a)))) + n)))) + +; ── follows + dashboard ────────────────────────────────────────────── + +(define + gitea/follow-key + (fn (user target) (str "gitea/follow/" user "/" target))) + +(define + gitea/follow-target-valid? + (fn + (forge target) + (cond + ((not (string? target)) false) + ((starts-with? target "user:") + (gitea/owner-exists? forge (substr target 5))) + ((starts-with? target "repo:") + (let + ((p (gitea/split-full (substr target 5)))) + (gitea/repo-exists? forge (get p :owner) (get p :name)))) + (else false)))) + +(define + gitea/follow! + (fn + (forge user target) + (cond + ((not (gitea/owner-exists? forge user)) {:error "no-such-user"}) + ((not (gitea/follow-target-valid? forge target)) {:error "no-such-target"}) + (else + (persist/kv-put + (gitea/forge-db forge) + (gitea/follow-key user target) + {:target target}))))) + +(define + gitea/unfollow! + (fn + (forge user target) + (let + ((k (gitea/follow-key user target))) + (if + (persist/kv-has? (gitea/forge-db forge) k) + (begin (persist/kv-delete (gitea/forge-db forge) k) true) + false)))) + +(define + gitea/follows + (fn (forge user) (gitea/names-under forge (str "gitea/follow/" user "/")))) + +; what the people/repos a user follows have been doing (own actions +; excluded, private repos only where the VIEWER can read) +(define + gitea/dashboard + (fn + (forge user n) + (let + ((follows (gitea/follows forge user))) + (feed/items + (feed/take + (feed/recent + (feed/filter + (gitea/activity-stream forge) + (fn + (a) + (and + (not (= (get a :actor) user)) + (gitea/act-visible? forge user a) + (or + (contains? follows (str "user:" (get a :actor))) + (let + ((r (gitea/act-repo a))) + (and (not (nil? r)) (contains? follows r)))))))) + n))))) + +; ── notifications over lib/events durable delivery ─────────────────── + +; who should hear about an activity (never its own actor) +(define + gitea/notify-recipients + (fn + (forge a) + (let + ((verb (get a :verb)) + (node (gitea/parse-numbered-node (or (get a :object) "")))) + (let + ((raw (cond ((nil? node) (list)) ((= verb "comment") (let ((rec (gitea/issue-get forge (get node :owner) (get node :name) (get node :n)))) (if (nil? rec) (list) (concat (list (get rec :author)) (concat (get rec :assignees) (map (fn (c) (get c :author)) (get rec :comments))))))) ((= verb "open-issue") (let ((rec (gitea/issue-get forge (get node :owner) (get node :name) (get node :n)))) (if (nil? rec) (list) (get rec :assignees)))) ((or (= verb "review") (= verb "merge-pr")) (let ((rec (gitea/pr-get forge (get node :owner) (get node :name) (get node :n)))) (if (nil? rec) (list) (list (get rec :author))))) (else (list))))) + (artdag/sort-strings + (relations-dedup + (filter + (fn + (u) + (and + (not (= u (get a :actor))) + (gitea/owner-exists? forge u))) + raw))))))) + +(define gitea/notify-cursor-key "gitea/notify-cursor") + +(define + gitea/notify-body + (fn (a) (str (get a :actor) " " (get a :verb) " " (get a :object)))) + +; messages for every activity after the cursor: (id recipient body), +; id = : so inbox keys sort chronologically +(define + gitea/pending-notifications + (fn + (forge) + (let + ((db (gitea/forge-db forge))) + (let + ((cursor (persist/kv-get-or db gitea/notify-cursor-key 0))) + (let + ((events (persist/read-from db gitea/activity-stream-name (+ cursor 1)))) + {:messages (reduce (fn (acc e) (let ((a (persist/event-data e))) (concat acc (map (fn (u) (list (str (gitea/pad8 (persist/event-seq e)) ":" u) u (gitea/notify-body a))) (gitea/notify-recipients forge a))))) (list) events) :last-seq (reduce (fn (acc e) (persist/event-seq e)) cursor events)}))))) + +(define gitea/inbox-key (fn (user id) (str "gitea/inbox/" user "/" id))) + +; deliver pending notifications through the durable digest flow and file +; the delivered ones into per-user inboxes; the cursor advance makes a +; re-run a no-op. => (("delivered"|"failed" id n-or-reason) ...) +(define + gitea/notify! + (fn + (forge) + (let + ((p (gitea/pending-notifications forge))) + (let + ((msgs (get p :messages))) + (let + ((by-id (reduce (fn (acc m) (assoc acc (first m) m)) {} msgs))) + (let + ((outcomes (if (empty? msgs) (list) (ev/deliver-messages msgs ev-notify-ok-transport 3 500)))) + (begin + (for-each + (fn + (o) + (if + (= (first o) "delivered") + (let + ((m (get by-id (nth o 1)))) + (if + (nil? m) + nil + (persist/kv-put + (gitea/forge-db forge) + (gitea/inbox-key (nth m 1) (first m)) + {:id (first m) :body (nth m 2)}))) + nil)) + outcomes) + (persist/kv-put + (gitea/forge-db forge) + gitea/notify-cursor-key + (get p :last-seq)) + outcomes))))))) + +(define + gitea/inbox + (fn + (forge user) + (map + (fn + (id) + (persist/kv-get (gitea/forge-db forge) (gitea/inbox-key user id))) + (gitea/names-under forge (str "gitea/inbox/" user "/"))))) + +(define gitea/inbox-count (fn (forge user) (len (gitea/inbox forge user)))) + +; ── web ────────────────────────────────────────────────────────────── + +(define + gitea/w-act-item + (fn + (a) + (str + "
  • " + (dream-escape (get a :actor)) + " " + (get a :verb) + " " + (dream-escape (or (get a :object) "")) + "
  • "))) + +(define + gitea/w-activity-page + (fn + (forge req) + (gitea/w-page + "activity" + (str + "

    Activity

      " + (join + "" + (map + gitea/w-act-item + (gitea/timeline forge (gitea/w-user forge req) 50))) + "
    ")))) + +(define + gitea/w-repo-activity-page + (fn + (forge req) + (let + ((owner (dream-param req "owner")) (name (dream-param req "name"))) + (if + (not (gitea/w-readable? forge req owner name)) + (dream-not-found) + (gitea/w-page + (str owner "/" name " activity") + (str + "

    Activity

      " + (join + "" + (map + gitea/w-act-item + (gitea/repo-timeline forge owner name 50))) + "
    ")))))) + +(define + gitea/w-api-user-activity + (fn + (forge req) + (let + ((user (dream-param req "user"))) + (if + (not (gitea/owner-exists? forge user)) + (dream-not-found) + (dream-json-value + (gitea/user-timeline forge (gitea/w-user forge req) user 50)))))) + +(define + gitea/w-api-dashboard + (fn + (forge req) + (let + ((user (gitea/w-user forge req))) + (if + (nil? user) + (gitea/w-unauthorized) + (dream-json-value (gitea/dashboard forge user 50)))))) + +(define + gitea/w-api-follow + (fn + (forge req) + (let + ((user (gitea/w-user forge req))) + (if + (nil? user) + (gitea/w-unauthorized) + (let + ((res (gitea/follow! forge user (get (dream-json-body req) :target)))) + (if + (get res :error) + (gitea/w-json-status 400 {:error (get res :error)}) + (dream-json-value (gitea/follows forge user)))))))) + +(define + gitea/w-api-unfollow + (fn + (forge req) + (let + ((user (gitea/w-user forge req))) + (if + (nil? user) + (gitea/w-unauthorized) + (if + (gitea/unfollow! forge user (or (dream-param req "**") "")) + (dream-json-value (gitea/follows forge user)) + (dream-not-found)))))) + +(define + gitea/w-api-notifications + (fn + (forge req) + (let + ((user (gitea/w-user forge req))) + (if + (nil? user) + (gitea/w-unauthorized) + (dream-json-value + (map (fn (r) (get r :body)) (gitea/inbox forge user))))))) + +(define + gitea/w-api-notify-run + (fn + (forge req) + (let + ((user (gitea/w-user forge req))) + (if (nil? user) (gitea/w-unauthorized) (dream-json-value {:outcomes (len (gitea/notify! forge))}))))) + +(define + gitea/activity-routes + (fn + (forge) + (list + (dream-get "/activity" (fn (req) (gitea/w-activity-page forge req))) + (dream-get + "/:owner/:name/activity" + (fn (req) (gitea/w-repo-activity-page forge req))) + (dream-get + "/api/users/:user/activity" + (fn (req) (gitea/w-api-user-activity forge req))) + (dream-get + "/api/dashboard" + (fn (req) (gitea/w-api-dashboard forge req))) + (dream-post "/api/follow" (fn (req) (gitea/w-api-follow forge req))) + (dream-delete + "/api/follow/**" + (fn (req) (gitea/w-api-unfollow forge req))) + (dream-get + "/api/notifications" + (fn (req) (gitea/w-api-notifications forge req))) + (dream-post + "/api/notify/run" + (fn (req) (gitea/w-api-notify-run forge req)))))) + +(set! + gitea/route-packs + (append gitea/route-packs (list gitea/activity-routes))) diff --git a/lib/gitea/conformance.sh b/lib/gitea/conformance.sh new file mode 100644 index 00000000..b33884da --- /dev/null +++ b/lib/gitea/conformance.sh @@ -0,0 +1,182 @@ +#!/usr/bin/env bash +# lib/gitea/conformance.sh — run sx-gitea test suites, emit scoreboard.json + scoreboard.md. +# +# Usage: +# bash lib/gitea/conformance.sh # run all suites +# bash lib/gitea/conformance.sh -v # also print failure details + +set -uo pipefail +cd "$(git rev-parse --show-toplevel)" + +SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}" +if [ ! -x "$SX_SERVER" ]; then + SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe" +fi +if [ ! -x "$SX_SERVER" ]; then + echo "ERROR: sx_server.exe not found." >&2 + exit 1 +fi + +VERBOSE="${1:-}" + +# suite name | pass counter | fail counter | failures list | extra modules (;-sep) +ISSUES_EXTRAS="lib/relations/schema.sx;lib/relations/engine.sx;lib/relations/api.sx;lib/smalltalk/tokenizer.sx;lib/smalltalk/parser.sx;lib/guest/reflective/class-chain.sx;lib/smalltalk/runtime.sx;lib/guest/reflective/env.sx;lib/smalltalk/eval.sx;lib/content/block.sx;lib/content/doc.sx;lib/content/render.sx;lib/content/api.sx;lib/content/meta.sx;lib/content/text.sx;lib/content/section.sx;lib/content/table.sx;lib/content/markdown.sx;lib/content/md-import.sx;lib/gitea/issues.sx" + +PR_EXTRAS="$ISSUES_EXTRAS;lib/guest/lex.sx;lib/guest/reflective/quoting.sx;lib/scheme/parser.sx;lib/scheme/eval.sx;lib/scheme/runtime.sx;lib/flow/spec.sx;lib/flow/store.sx;lib/flow/remote.sx;lib/flow/host.sx;lib/flow/api.sx;lib/gitea/pr.sx" +SEARCH_EXTRAS_TAIL="lib/haskell/tokenizer.sx;lib/haskell/layout.sx;lib/haskell/parser.sx;lib/haskell/desugar.sx;lib/haskell/runtime.sx;lib/haskell/match.sx;lib/haskell/eval.sx;lib/haskell/map.sx;lib/haskell/set.sx;lib/haskell/testlib.sx;lib/search/tokenize.sx;lib/search/index.sx;lib/search/query.sx;lib/search/parse.sx;lib/search/rank.sx;lib/search/rankq.sx;lib/search/testlib.sx;lib/gitea/search.sx" +ACT_EXTRAS="$PR_EXTRAS;lib/apl/runtime.sx;lib/feed/normalize.sx;lib/feed/stream.sx;lib/feed/api.sx;lib/feed/fanout.sx;lib/feed/dedupe.sx;lib/feed/aggregate.sx;lib/feed/rank.sx;lib/feed/acl.sx;lib/feed/mute.sx;lib/feed/page.sx;lib/feed/notify.sx;lib/feed/home.sx;lib/feed/fed.sx;lib/events/notify.sx;lib/gitea/activity.sx" + +SUITES=( + "repo|gitea-repo-pass|gitea-repo-fail|gitea-repo-fails|" + "access|gitea-access-pass|gitea-access-fail|gitea-access-fails|" + "wire|gitea-wire-pass|gitea-wire-fail|gitea-wire-fails|" + "issues|gitea-issues-pass|gitea-issues-fail|gitea-issues-fails|$ISSUES_EXTRAS" + "pr|gitea-pr-pass|gitea-pr-fail|gitea-pr-fails|$PR_EXTRAS" + "activity|gitea-act-pass|gitea-act-fail|gitea-act-fails|$ACT_EXTRAS" + "search|gitea-search-pass|gitea-search-fail|gitea-search-fails|$PR_EXTRAS;$SEARCH_EXTRAS_TAIL" + "fed|gitea-fed-pass|gitea-fed-fail|gitea-fed-fails|$ACT_EXTRAS;lib/gitea/fed.sx" +) + +OUT_JSON="lib/gitea/scoreboard.json" +OUT_MD="lib/gitea/scoreboard.md" + +# Library load order: kernel stdlib, persist, artdag canon, sx-git, dream +# (types/router/middleware/error/html/json/api), then the gitea modules. +MODULES=( + "spec/stdlib.sx" + "spec/parser.sx" + "lib/r7rs.sx" + "lib/persist/event.sx" + "lib/persist/backend.sx" + "lib/persist/log.sx" + "lib/persist/kv.sx" + "lib/artdag/dag.sx" + "lib/git/object.sx" + "lib/git/ref.sx" + "lib/git/dag.sx" + "lib/git/worktree.sx" + "lib/git/diff.sx" + "lib/git/merge.sx" + "lib/git/porcelain.sx" + "lib/datalog/tokenizer.sx" + "lib/datalog/parser.sx" + "lib/datalog/unify.sx" + "lib/datalog/db.sx" + "lib/datalog/builtins.sx" + "lib/datalog/aggregates.sx" + "lib/datalog/strata.sx" + "lib/datalog/eval.sx" + "lib/datalog/api.sx" + "lib/datalog/magic.sx" + "lib/acl/schema.sx" + "lib/acl/facts.sx" + "lib/acl/engine.sx" + "lib/dream/types.sx" + "lib/dream/router.sx" + "lib/dream/middleware.sx" + "lib/dream/error.sx" + "lib/dream/html.sx" + "lib/dream/json.sx" + "lib/dream/auth.sx" + "lib/dream/api.sx" + "lib/gitea/repo.sx" + "lib/gitea/access.sx" + "lib/gitea/web.sx" + "lib/gitea/wire.sx" +) + +run_suite() { + local suite=$1 passvar=$2 failvar=$3 failsvar=$4 extras=$5 + local file="lib/gitea/tests/${suite}.sx" + local TMP + TMP=$(mktemp) + { + echo "(epoch 1)" + for M in "${MODULES[@]}"; do echo "(load \"$M\")"; done + if [ -n "$extras" ]; then + for M in ${extras//;/ }; do echo "(load \"$M\")"; done + fi + echo "(epoch 2)" + echo "(load \"${file}\")" + echo "(epoch 3)" + echo "(eval \"(list ${passvar} ${failvar})\")" + echo "(epoch 4)" + echo "(eval \"(inspect ${failsvar})\")" + } > "$TMP" + + local OUTPUT + OUTPUT=$(timeout 900 "$SX_SERVER" < "$TMP" 2>/dev/null) + rm -f "$TMP" + + local LINE + LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 3 / {getline; print; exit}') + if [ -z "$LINE" ]; then + LINE=$(echo "$OUTPUT" | grep -E '^\(ok 3 \([0-9]+ [0-9]+\)\)' | tail -1 \ + | sed -E 's/^\(ok 3 //; s/\)$//') + fi + + local P F + P=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\1/') + F=$(echo "$LINE" | sed -E 's/^\(([0-9]+) ([0-9]+)\).*/\2/') + P=${P:-0} + F=${F:-0} + + if [ -n "$VERBOSE" ] && [ "$F" != "0" ]; then + echo " --- ${suite} failures ---" >&2 + echo "$OUTPUT" | awk '/^\(ok(-len)? 4 /,0' | head -40 >&2 + fi + + echo "${P} ${F}" +} + +declare -A SUITE_PASS +declare -A SUITE_FAIL +TOTAL_PASS=0 +TOTAL_FAIL=0 + +echo "Running sx-gitea conformance suite..." >&2 +for entry in "${SUITES[@]}"; do + IFS='|' read -r s passvar failvar failsvar extras <<< "$entry" + read -r p f < <(run_suite "$s" "$passvar" "$failvar" "$failsvar" "$extras") + SUITE_PASS[$s]=$p + SUITE_FAIL[$s]=$f + TOTAL_PASS=$((TOTAL_PASS + p)) + TOTAL_FAIL=$((TOTAL_FAIL + f)) + printf " %-12s %d/%d\n" "$s" "$p" "$((p+f))" >&2 +done + +{ + printf '{\n' + printf ' "suites": {\n' + first=1 + for entry in "${SUITES[@]}"; do + IFS='|' read -r s _ _ _ _ <<< "$entry" + if [ $first -eq 0 ]; then printf ',\n'; fi + printf ' "%s": {"pass": %d, "fail": %d}' "$s" "${SUITE_PASS[$s]}" "${SUITE_FAIL[$s]}" + first=0 + done + printf '\n },\n' + printf ' "total_pass": %d,\n' "$TOTAL_PASS" + printf ' "total_fail": %d,\n' "$TOTAL_FAIL" + printf ' "total": %d\n' "$((TOTAL_PASS + TOTAL_FAIL))" + printf '}\n' +} > "$OUT_JSON" + +{ + printf '# sx-gitea Conformance Scoreboard\n\n' + printf '_Generated by `lib/gitea/conformance.sh`_\n\n' + printf '| Suite | Pass | Fail | Total |\n' + printf '|-------|-----:|-----:|------:|\n' + for entry in "${SUITES[@]}"; do + IFS='|' read -r s _ _ _ _ <<< "$entry" + p=${SUITE_PASS[$s]} + f=${SUITE_FAIL[$s]} + printf '| %s | %d | %d | %d |\n' "$s" "$p" "$f" "$((p+f))" + done + printf '| **Total** | **%d** | **%d** | **%d** |\n' "$TOTAL_PASS" "$TOTAL_FAIL" "$((TOTAL_PASS + TOTAL_FAIL))" +} > "$OUT_MD" + +echo "Wrote $OUT_JSON and $OUT_MD" >&2 +echo "Total: $TOTAL_PASS pass, $TOTAL_FAIL fail" >&2 + +[ "$TOTAL_FAIL" -eq 0 ] diff --git a/lib/gitea/fed.sx b/lib/gitea/fed.sx new file mode 100644 index 00000000..2c6d3e79 --- /dev/null +++ b/lib/gitea/fed.sx @@ -0,0 +1,449 @@ +; lib/gitea/fed.sx — sx-gitea Phase 8: ForgeFed federation. +; +; Forges federate as fed-sx-style peers. Each forge carries an instance +; id; users and repos project as AP actor documents (Person/Repository +; with inbox/outbox); the outbox is the forge's activity log in an +; AP-shaped envelope ({:actor "/user:" :verb :object +; :published}). +; +; Trust is the events-federation pattern: a kv set of peer ids, +; RE-CHECKED on every operation, so revoking a peer takes effect +; immediately. Peer transports (dream app fns) live in the forge handle's +; runtime cache — only the trust set persists. +; +; The inbox (POST /api/ap/inbox, {:peer :activity}) accepts activities +; from trusted peers only. Every accepted activity lands in a federated +; activity log with :origin provenance; open-issue/comment/open-pr +; activities also MATERIALIZE: the foreign author becomes a proxy user +; "@" (auto-created), and the issue/comment/PR is created +; locally under that identity — federated issues and PRs with honest +; provenance. fed-deliver! pushes public-repo activities (cursor-based, +; never private ones) to every trusted peer's inbox. +; +; Cross-instance repo follow = mirror!: clone a trusted peer's repo over +; the Phase 3 wire client, remember the source, and mirror-sync! to +; fast-forward — trust re-checked on every sync. +; +; Requires: lib/gitea/{repo,access,web,wire,issues,pr,activity}.sx and +; their stacks. + +; ── instance identity ──────────────────────────────────────────────── + +(define gitea/instance-key "gitea/instance") + +(define + gitea/instance! + (fn + (forge id) + (persist/kv-put (gitea/forge-db forge) gitea/instance-key {:id id}))) + +(define + gitea/instance-id + (fn + (forge) + (get + (or + (persist/kv-get (gitea/forge-db forge) gitea/instance-key) + {}) + :id))) + +(define + gitea/actor-id + (fn (forge node) (str (or (gitea/instance-id forge) "local") "/" node))) + +; ── peers + trust ──────────────────────────────────────────────────── + +; transports are live functions — runtime registry in the forge cache +(define + gitea/peers-registry + (fn + (forge) + (let + ((cache (get forge :cache))) + (begin + (if + (and cache (nil? (get cache "peers"))) + (dict-set! cache "peers" {}) + nil) + (or (get cache "peers") {}))))) + +(define + gitea/peer-register! + (fn + (forge id app token) + (let + ((cache (get forge :cache))) + (begin + (dict-set! + cache + "peers" + (assoc (gitea/peers-registry forge) id {:id id :token token :app app})) + id)))) + +(define + gitea/peer-get + (fn (forge id) (get (gitea/peers-registry forge) id))) + +(define gitea/trust-key (fn (id) (str "gitea/trust/" id))) + +(define + gitea/trust! + (fn + (forge id) + (persist/kv-put (gitea/forge-db forge) (gitea/trust-key id) {:id id}))) + +(define + gitea/untrust! + (fn + (forge id) + (persist/kv-delete (gitea/forge-db forge) (gitea/trust-key id)))) + +(define + gitea/trusted? + (fn + (forge id) + (persist/kv-has? (gitea/forge-db forge) (gitea/trust-key id)))) + +(define + gitea/trusted-peers + (fn + (forge) + (filter + (fn (id) (gitea/trusted? forge id)) + (artdag/sort-strings (keys (gitea/peers-registry forge)))))) + +; ── AP actor documents ─────────────────────────────────────────────── + +(define + gitea/ap-user + (fn + (forge user) + (let + ((rec (gitea/owner-get forge user))) + (if (nil? rec) nil {:id (gitea/actor-id forge (str "user:" user)) :type (if (gitea/org? rec) "Group" "Person") :outbox (str "/api/ap/users/" user "/outbox") :preferredUsername user :inbox "/api/ap/inbox"})))) + +(define + gitea/ap-repo + (fn + (forge owner name) + (let + ((rec (gitea/repo-get forge owner name))) + (if (nil? rec) nil {:clone (str "/" owner "/" name "/info/refs") :name (str owner "/" name) :id (gitea/actor-id forge (str "repo:" owner "/" name)) :attributedTo (gitea/actor-id forge (str "user:" owner)) :type "Repository" :summary (get rec :description) :inbox "/api/ap/inbox"})))) + +; AP-shaped envelope for a feed activity +(define gitea/ap-activity (fn (forge a) {:published (get a :at) :actor (gitea/actor-id forge (str "user:" (get a :actor))) :object (get a :object) :verb (get a :verb)})) + +(define + gitea/ap-outbox + (fn + (forge user n) + (map + (fn (a) (gitea/ap-activity forge a)) + (gitea/user-timeline forge nil user n)))) + +; ── federated activity log (inbound, with provenance) ──────────────── + +(define gitea/fed-stream-name "gitea/fed-activity") + +(define + gitea/fed-log + (fn + (forge) + (map + persist/event-data + (persist/read (gitea/forge-db forge) gitea/fed-stream-name)))) + +(define + gitea/fed-log-append! + (fn + (forge origin a) + (persist/append + (gitea/forge-db forge) + gitea/fed-stream-name + (or (get a :verb) "activity") + (or (get a :at) 0) + {:activity a :origin origin}))) + +; local + foreign activities, newest first, foreign tagged :origin +(define + gitea/fed-timeline + (fn + (forge user n) + (feed/items + (feed/take + (feed/recent + (feed/stream + (concat + (feed/items + (feed/filter + (gitea/activity-stream forge) + (fn (a) (gitea/act-visible? forge user a)))) + (map + (fn (e) (assoc (get e :activity) :origin (get e :origin))) + (gitea/fed-log forge))))) + n)))) + +; ── inbound materialization ────────────────────────────────────────── + +; foreign authors become local proxy users "@" +(define + gitea/fed-user! + (fn + (forge name peer) + (let + ((proxy (str name "@" peer))) + (begin + (if + (gitea/owner-exists? forge proxy) + nil + (gitea/user-create! forge proxy)) + proxy)))) + +; a foreign activity's :actor may be "/user:" or a bare +; name — reduce it to the name +(define + gitea/fed-actor-name + (fn + (actor) + (let + ((i (index-of (or actor "") "user:"))) + (if (< i 0) (or actor "") (substr actor (+ i 5)))))) + +; apply one trusted activity: log it, and materialize the verbs a forge +; can host locally. => {:accepted true ...} | {:error ...} +(define + gitea/fed-receive! + (fn + (forge peer a) + (if + (not (gitea/trusted? forge peer)) + {:error "untrusted-peer"} + (let + ((verb (get a :verb)) + (actor (gitea/fed-actor-name (get a :actor))) + (node (gitea/parse-numbered-node (or (get a :object) ""))) + (detail (or (get a :detail) {}))) + (begin + (gitea/fed-log-append! forge peer a) + (cond + ((= verb "open-issue") + (let + ((rp (gitea/split-full (substr (or (gitea/act-repo a) "repo:/") 5)))) + (let + ((res (gitea/issue-create! forge (get rp :owner) (get rp :name) (gitea/fed-user! forge actor peer) (or (get detail :title) "(federated issue)") (or (get detail :body) "") {:created-at (or (get a :at) 0)}))) + (if (get res :error) res {:materialized "issue" :accepted true :number (get res :number)})))) + ((= verb "comment") + (if + (nil? node) + {:error "bad-object"} + (let + ((res (gitea/issue-comment! forge (get node :owner) (get node :name) (get node :n) (gitea/fed-user! forge actor peer) (or (get detail :body) "") {:at (or (get a :at) 0)}))) + (if (get res :error) res {:materialized "comment" :accepted true})))) + ((= verb "open-pr") + (let + ((rp (gitea/split-full (substr (or (gitea/act-repo a) "repo:/") 5)))) + (let + ((res (gitea/pr-create! forge (get rp :owner) (get rp :name) (gitea/fed-user! forge actor peer) (or (get detail :title) "(federated pr)") (get detail :source) (get detail :target) (or (get detail :body) "") {:created-at (or (get a :at) 0)}))) + (if (get res :error) res {:materialized "pr" :accepted true :number (get res :number)})))) + (else {:materialized "none" :accepted true}))))))) + +; ── outbound delivery ──────────────────────────────────────────────── + +(define gitea/fed-cursor-key "gitea/fed-cursor") + +; push public-repo activities after the cursor to every trusted peer's +; inbox. => {:delivered n :peers (ids)} +(define + gitea/fed-deliver! + (fn + (forge) + (let + ((db (gitea/forge-db forge))) + (let + ((cursor (persist/kv-get-or db gitea/fed-cursor-key 0)) + (peers (gitea/trusted-peers forge)) + (me (or (gitea/instance-id forge) "local"))) + (let + ((events (persist/read-from db gitea/activity-stream-name (+ cursor 1)))) + (let + ((public (filter (fn (e) (gitea/act-visible? forge nil (persist/event-data e))) events))) + (begin + (for-each + (fn + (e) + (for-each + (fn + (pid) + (let + ((peer (gitea/peer-get forge pid))) + (if + (nil? peer) + nil + ((get peer :app) + (dream-request + "POST" + "/api/ap/inbox" + (if + (nil? (get peer :token)) + {} + {:authorization (str "Bearer " (get peer :token))}) + (dream-json-encode {:activity (persist/event-data e) :peer me})))))) + peers)) + public) + (if + (empty? events) + nil + (persist/kv-put + db + gitea/fed-cursor-key + (reduce (fn (acc e) (persist/event-seq e)) cursor events))) + {:delivered (len public) :peers peers}))))))) + +; ── cross-instance repo follow (mirrors) ───────────────────────────── + +(define + gitea/mirror-key + (fn (owner name) (str "gitea/mirror/" owner "/" name))) + +(define + gitea/peer-remote + (fn + (forge peer-id owner name) + (let + ((peer (gitea/peer-get forge peer-id))) + (if + (nil? peer) + nil + (gitea/remote (get peer :app) owner name (get peer :token)))))) + +; clone a trusted peer's repo as owner/name and remember the source +(define + gitea/mirror! + (fn + (forge owner name peer-id remote-owner remote-name) + (cond + ((not (gitea/trusted? forge peer-id)) {:error "untrusted-peer"}) + ((nil? (gitea/peer-get forge peer-id)) {:error "no-such-peer"}) + (else + (let + ((remote (gitea/peer-remote forge peer-id remote-owner remote-name))) + (let + ((res (gitea/clone! forge owner name remote {}))) + (if + (or (get res :error) (get res :conflict)) + res + (begin + (persist/kv-put + (gitea/forge-db forge) + (gitea/mirror-key owner name) + {:remote-owner remote-owner :peer peer-id :remote-name remote-name}) + res)))))))) + +(define + gitea/mirror-of + (fn + (forge owner name) + (persist/kv-get (gitea/forge-db forge) (gitea/mirror-key owner name)))) + +(define + gitea/mirrors + (fn (forge) (gitea/names-under forge "gitea/mirror/"))) + +; re-fetch from the mirror source; trust is re-checked every sync +(define + gitea/mirror-sync! + (fn + (forge owner name) + (let + ((m (gitea/mirror-of forge owner name))) + (cond + ((nil? m) {:error "not-a-mirror"}) + ((not (gitea/trusted? forge (get m :peer))) {:error "untrusted-peer"}) + ((nil? (gitea/peer-get forge (get m :peer))) {:error "no-such-peer"}) + (else + (gitea/fetch! + (gitea/peer-remote + forge + (get m :peer) + (get m :remote-owner) + (get m :remote-name)) + (gitea/repo-git forge owner name))))))) + +; ── web ────────────────────────────────────────────────────────────── + +(define + gitea/w-ap-user + (fn + (forge req) + (let + ((doc (gitea/ap-user forge (dream-param req "user")))) + (if (nil? doc) (dream-not-found) (dream-json-value doc))))) + +(define + gitea/w-ap-repo + (fn + (forge req) + (let + ((owner (dream-param req "owner")) (name (dream-param req "name"))) + (if + (not (gitea/w-readable? forge req owner name)) + (dream-not-found) + (dream-json-value (gitea/ap-repo forge owner name)))))) + +(define + gitea/w-ap-outbox + (fn + (forge req) + (let + ((user (dream-param req "user"))) + (if + (not (gitea/owner-exists? forge user)) + (dream-not-found) + (dream-json-value (gitea/ap-outbox forge user 50)))))) + +(define + gitea/w-ap-inbox + (fn + (forge req) + (let + ((body (dream-json-body req))) + (let + ((peer (get body :peer))) + (cond + ((nil? peer) (gitea/w-json-status 400 {:error "missing-peer"})) + ((not (gitea/trusted? forge peer)) (gitea/w-forbidden)) + (else + (let + ((res (gitea/fed-receive! forge peer (or (get body :activity) {})))) + (if + (get res :error) + (gitea/w-json-status 400 {:error (get res :error)}) + (dream-json-value res))))))))) + +(define + gitea/w-fed-timeline + (fn + (forge req) + (dream-json-value + (gitea/fed-timeline forge (gitea/w-user forge req) 50)))) + +(define + gitea/fed-routes + (fn + (forge) + (list + (dream-get + "/api/ap/users/:user" + (fn (req) (gitea/w-ap-user forge req))) + (dream-get + "/api/ap/users/:user/outbox" + (fn (req) (gitea/w-ap-outbox forge req))) + (dream-get + "/api/ap/repos/:owner/:name" + (fn (req) (gitea/w-ap-repo forge req))) + (dream-post "/api/ap/inbox" (fn (req) (gitea/w-ap-inbox forge req))) + (dream-get + "/api/fed/timeline" + (fn (req) (gitea/w-fed-timeline forge req)))))) + +(set! gitea/route-packs (append gitea/route-packs (list gitea/fed-routes))) diff --git a/lib/gitea/issues.sx b/lib/gitea/issues.sx new file mode 100644 index 00000000..a7bd6841 --- /dev/null +++ b/lib/gitea/issues.sx @@ -0,0 +1,770 @@ +; lib/gitea/issues.sx — sx-gitea Phase 4: issues. +; +; An issue is a kv record: number, title, author, state, label/assignee +; sets, a Markdown body, and a comment thread (each comment is Markdown +; too). The Markdown is the stored source of truth; lib/content turns it +; into a block document (content/from-markdown) and renders HTML +; (content/html) — content-on-sx's round-trip law keeps the two views of +; the same body honest. +; +; The issue graph (issue->repo, author, assignees, labels, commenters) is +; DERIVED from the records into lib/relations facts — like the acl db in +; access.sx, the relations db is rebuilt (cached on fact equality) rather +; than maintained incrementally, so deleting a repo can never leave +; dangling edges. +; +; Requires: lib/gitea/{repo,access,web}.sx and their stacks, plus +; lib/relations/{schema,engine,api}.sx and the content stack +; (lib/smalltalk/* + lib/content/{block,doc,render,api,meta,text,section, +; table,markdown,md-import}.sx) with content bootstrapped: +; (st-bootstrap-classes!) (content/bootstrap!) +; (content-bootstrap-markdown!) (content-bootstrap-table!) + +; ── numbering / keys ───────────────────────────────────────────────── +; keys carry zero-padded numbers so lexicographic kv order = issue order + +(define + gitea/pad8 + (fn + (n) + (let + ((s (str n))) + (str + (substr "00000000" 0 (- 8 (string-length s))) + s)))) + +(define + gitea/digits-loop + (fn + (s i) + (if + (>= i (string-length s)) + true + (let + ((c (char-code (char-at s i)))) + (if + (and (>= c 48) (<= c 57)) + (gitea/digits-loop s (+ i 1)) + false))))) + +(define + gitea/digits? + (fn + (s) + (and + (string? s) + (> (string-length s) 0) + (gitea/digits-loop s 0)))) + +(define + gitea/issue-key + (fn (owner name n) (str "gitea/issue/" owner "/" name "/" (gitea/pad8 n)))) + +(define + gitea/issue-seq-key + (fn (owner name) (str "gitea/issue-seq/" owner "/" name))) + +(define + gitea/issue-next! + (fn + (forge owner name) + (let + ((k (gitea/issue-seq-key owner name))) + (let + ((n (+ 1 (or (persist/kv-get (gitea/forge-db forge) k) 0)))) + (begin (persist/kv-put (gitea/forge-db forge) k n) n))))) + +; ── sorted-set helpers ─────────────────────────────────────────────── + +(define + gitea/set-add + (fn + (xs x) + (artdag/sort-strings (cons x (filter (fn (e) (not (= e x))) xs))))) + +(define gitea/set-remove (fn (xs x) (filter (fn (e) (not (= e x))) xs))) + +; ── issue CRUD ─────────────────────────────────────────────────────── + +(define + gitea/issue-create! + (fn + (forge owner name author title body opts) + (cond + ((not (gitea/repo-exists? forge owner name)) {:error "no-such-repo"}) + ((not (gitea/owner-exists? forge author)) {:error "no-such-user"}) + ((or (not (string? title)) (= title "")) {:error "empty-title"}) + (else + (let + ((o (or opts {}))) + (let + ((n (gitea/issue-next! forge owner name))) + (let + ((rec {:state "open" :comments (list) :title title :body (or body "") :number n :author author :created-at (or (get o :created-at) 0) :assignees (artdag/sort-strings (or (get o :assignees) (list))) :labels (artdag/sort-strings (or (get o :labels) (list)))})) + (begin + (persist/kv-put + (gitea/forge-db forge) + (gitea/issue-key owner name n) + rec) + rec)))))))) + +(define + gitea/issue-get + (fn + (forge owner name n) + (persist/kv-get (gitea/forge-db forge) (gitea/issue-key owner name n)))) + +(define + gitea/issues + (fn + (forge owner name) + (map + (fn (s) (parse-int s)) + (gitea/names-under forge (str "gitea/issue/" owner "/" name "/"))))) + +(define + gitea/issue-records + (fn + (forge owner name) + (map + (fn (n) (gitea/issue-get forge owner name n)) + (gitea/issues forge owner name)))) + +(define + gitea/issue-update! + (fn + (forge owner name n f) + (let + ((rec (gitea/issue-get forge owner name n))) + (if + (nil? rec) + nil + (persist/kv-put + (gitea/forge-db forge) + (gitea/issue-key owner name n) + (f rec)))))) + +(define + gitea/issue-close! + (fn + (forge owner name n) + (gitea/issue-update! + forge + owner + name + n + (fn (r) (assoc r :state "closed"))))) + +(define + gitea/issue-reopen! + (fn + (forge owner name n) + (gitea/issue-update! + forge + owner + name + n + (fn (r) (assoc r :state "open"))))) + +(define + gitea/issue-comment! + (fn + (forge owner name n author body opts) + (cond + ((not (gitea/owner-exists? forge author)) {:error "no-such-user"}) + ((nil? (gitea/issue-get forge owner name n)) {:error "no-such-issue"}) + (else + (let + ((comment {:body (or body "") :at (or (get (or opts {}) :at) 0) :author author})) + (begin + (gitea/issue-update! + forge + owner + name + n + (fn + (r) + (assoc + r + :comments (append (get r :comments) (list comment))))) + comment)))))) + +; ── labels / assignees ─────────────────────────────────────────────── + +(define + gitea/issue-label! + (fn + (forge owner name n label) + (if + (or (not (string? label)) (= label "")) + {:error "invalid-label"} + (gitea/issue-update! + forge + owner + name + n + (fn (r) (assoc r :labels (gitea/set-add (get r :labels) label))))))) + +(define + gitea/issue-unlabel! + (fn + (forge owner name n label) + (gitea/issue-update! + forge + owner + name + n + (fn (r) (assoc r :labels (gitea/set-remove (get r :labels) label)))))) + +(define + gitea/issue-assign! + (fn + (forge owner name n user) + (if + (not (gitea/owner-exists? forge user)) + {:error "no-such-user"} + (gitea/issue-update! + forge + owner + name + n + (fn + (r) + (assoc r :assignees (gitea/set-add (get r :assignees) user))))))) + +(define + gitea/issue-unassign! + (fn + (forge owner name n user) + (gitea/issue-update! + forge + owner + name + n + (fn + (r) + (assoc r :assignees (gitea/set-remove (get r :assignees) user)))))) + +; ── views over the records ─────────────────────────────────────────── + +(define + gitea/issues-open + (fn + (forge owner name) + (filter + (fn (r) (= (get r :state) "open")) + (gitea/issue-records forge owner name)))) + +(define + gitea/issues-closed + (fn + (forge owner name) + (filter + (fn (r) (= (get r :state) "closed")) + (gitea/issue-records forge owner name)))) + +(define + gitea/issues-with-label + (fn + (forge owner name label) + (filter + (fn (r) (contains? (get r :labels) label)) + (gitea/issue-records forge owner name)))) + +(define + gitea/issues-assigned + (fn + (forge owner name user) + (filter + (fn (r) (contains? (get r :assignees) user)) + (gitea/issue-records forge owner name)))) + +; ── content documents ──────────────────────────────────────────────── + +(define gitea/md-doc (fn (md id) (content/from-markdown (or md "") id))) + +(define gitea/md-html (fn (md id) (content/html (gitea/md-doc md id)))) + +(define + gitea/issue-doc + (fn + (owner name issue) + (gitea/md-doc + (get issue :body) + (str "issue-" owner "-" name "-" (get issue :number))))) + +(define + gitea/issue-html + (fn (owner name issue) (content/html (gitea/issue-doc owner name issue)))) + +; ── relations graph (derived) ──────────────────────────────────────── + +(define gitea/user-node (fn (user) (str "user:" user))) +(define gitea/repo-node (fn (owner name) (str "repo:" owner "/" name))) +(define + gitea/issue-node + (fn (owner name n) (str "issue:" owner "/" name "#" n))) +(define + gitea/label-node + (fn (owner name label) (str "label:" owner "/" name "/" label))) + +(define + gitea/rel-facts + (fn + (forge) + (let + ((facts (list))) + (begin + (for-each + (fn + (full) + (let + ((p (gitea/split-full full))) + (let + ((owner (get p :owner)) (name (get p :name))) + (for-each + (fn + (rec) + (let + ((inode (gitea/issue-node owner name (get rec :number)))) + (begin + (append! + facts + (relations-rel + inode + (gitea/repo-node owner name) + (quote parent))) + (append! + facts + (relations-rel + inode + (gitea/user-node (get rec :author)) + (quote origin))) + (for-each + (fn + (a) + (append! + facts + (relations-rel + (gitea/user-node a) + inode + (quote member)))) + (get rec :assignees)) + (for-each + (fn + (l) + (append! + facts + (relations-rel + inode + (gitea/label-node owner name l) + (quote link)))) + (get rec :labels)) + (for-each + (fn + (c) + (append! + facts + (relations-rel + (gitea/user-node (get c :author)) + inode + (quote reply)))) + (get rec :comments))))) + (gitea/issue-records forge owner name))))) + (gitea/repos forge)) + facts)))) + +; rebuild only when the derived facts changed (cache in the forge handle) +(define + gitea/rels-db + (fn + (forge) + (let + ((facts (gitea/rel-facts forge)) (cache (get forge :cache))) + (if + (and cache (= (get cache "rel-facts") facts) (get cache "rels-db")) + (get cache "rels-db") + (let + ((db (relations-build-db facts))) + (begin + (if + cache + (begin + (dict-set! cache "rel-facts" facts) + (dict-set! cache "rels-db" db)) + nil) + db)))))) + +; issues of a repo, by graph (sorted issue node ids) +(define + gitea/repo-issue-nodes + (fn + (forge owner name) + (artdag/sort-strings + (relations-parents-of + (gitea/rels-db forge) + (gitea/repo-node owner name) + (quote parent))))) + +; issues a user authored +(define + gitea/user-authored + (fn + (forge user) + (artdag/sort-strings + (relations-parents-of + (gitea/rels-db forge) + (gitea/user-node user) + (quote origin))))) + +; issues assigned to a user +(define + gitea/user-assigned + (fn + (forge user) + (artdag/sort-strings + (relations-children-of + (gitea/rels-db forge) + (gitea/user-node user) + (quote member))))) + +; issues carrying a label +(define + gitea/label-issues + (fn + (forge owner name label) + (artdag/sort-strings + (relations-parents-of + (gitea/rels-db forge) + (gitea/label-node owner name label) + (quote link))))) + +; everyone touching an issue: author + assignees + commenters +(define + gitea/issue-participants + (fn + (forge owner name n) + (let + ((inode (gitea/issue-node owner name n)) (db (gitea/rels-db forge))) + (artdag/sort-strings + (relations-dedup + (concat + (relations-children-of db inode (quote origin)) + (concat + (relations-parents-of db inode (quote member)) + (relations-parents-of db inode (quote reply))))))))) + +; ── web ────────────────────────────────────────────────────────────── + +(define + gitea/w-issue-n + (fn + (req) + (let + ((s (dream-param req "n"))) + (if (gitea/digits? s) (parse-int s) nil)))) + +(define + gitea/w-issue-item + (fn + (owner name r) + (str + "
  • #" + (get r :number) + " " + (dream-escape (get r :title)) + " [" + (get r :state) + "]
  • "))) + +(define + gitea/w-issues-page + (fn + (forge req) + (let + ((owner (dream-param req "owner")) (name (dream-param req "name"))) + (if + (not (gitea/w-readable? forge req owner name)) + (dream-not-found) + (gitea/w-page + (str owner "/" name " issues") + (str + "

    Issues

      " + (join + "" + (map + (fn (r) (gitea/w-issue-item owner name r)) + (gitea/issue-records forge owner name))) + "
    ")))))) + +(define + gitea/w-comment-html + (fn + (owner name n i c) + (str + "

    " + (dream-escape (get c :author)) + "

    " + (gitea/md-html (get c :body) (str "c-" owner "-" name "-" n "-" i)) + "
    "))) + +(define + gitea/w-issue-page + (fn + (forge req) + (let + ((owner (dream-param req "owner")) + (name (dream-param req "name")) + (n (gitea/w-issue-n req))) + (if + (or (nil? n) (not (gitea/w-readable? forge req owner name))) + (dream-not-found) + (let + ((rec (gitea/issue-get forge owner name n))) + (if + (nil? rec) + (dream-not-found) + (gitea/w-page + (str "#" n " " (get rec :title)) + (str + "

    #" + n + " " + (dream-escape (get rec :title)) + "

    " + "

    " + (get rec :state) + "

    " + "

    " + (dream-escape (get rec :author)) + "

    " + "

    " + (dream-escape (join ", " (get rec :labels))) + "

    " + "

    " + (dream-escape (join ", " (get rec :assignees))) + "

    " + "
    " + (gitea/issue-html owner name rec) + "
    " + "

    Comments

    " + (join + "" + (map-indexed + (fn (i c) (gitea/w-comment-html owner name n i c)) + (get rec :comments))))))))))) + +; ── json api ───────────────────────────────────────────────────────── + +(define + gitea/w-api-issues + (fn + (forge req) + (let + ((owner (dream-param req "owner")) (name (dream-param req "name"))) + (if + (not (gitea/w-readable? forge req owner name)) + (dream-not-found) + (dream-json-value + (map (fn (r) {:state (get r :state) :title (get r :title) :number (get r :number)}) (gitea/issue-records forge owner name))))))) + +; any authenticated reader may open an issue +(define + gitea/w-api-issue-create + (fn + (forge req) + (let + ((owner (dream-param req "owner")) (name (dream-param req "name"))) + (let + ((user (gitea/w-user forge req))) + (cond + ((not (gitea/can? forge user "read" owner name)) + (if + (nil? user) + (if + (gitea/repo-exists? forge owner name) + (if + (equal? + (get (gitea/repo-get forge owner name) :visibility) + "public") + (gitea/w-unauthorized) + (dream-not-found)) + (dream-not-found)) + (dream-not-found))) + ((nil? user) (gitea/w-unauthorized)) + (else + (let + ((body (dream-json-body req))) + (let + ((res (gitea/issue-create! forge owner name user (get body :title) (or (get body :body) "") {:created-at (or (get body :created-at) 0) :assignees (or (get body :assignees) (list)) :labels (or (get body :labels) (list))}))) + (if + (get res :error) + (gitea/w-json-status 400 {:error (get res :error)}) + (gitea/w-json-status 201 {:title (get res :title) :number (get res :number)})))))))))) + +(define + gitea/w-api-issue-comment + (fn + (forge req) + (let + ((owner (dream-param req "owner")) + (name (dream-param req "name")) + (n (gitea/w-issue-n req))) + (let + ((user (gitea/w-user forge req))) + (cond + ((or (nil? n) (not (gitea/can? forge user "read" owner name))) + (dream-not-found)) + ((nil? user) (gitea/w-unauthorized)) + (else + (let + ((body (dream-json-body req))) + (let + ((res (gitea/issue-comment! forge owner name n user (or (get body :body) "") {:at (or (get body :created-at) 0)}))) + (if + (get res :error) + (gitea/w-json-status 404 {:error (get res :error)}) + (dream-json-value {:author user})))))))))) + +; the author or anyone with write may close/reopen +(define + gitea/issue-can-close? + (fn + (forge user owner name rec) + (or + (= user (get rec :author)) + (gitea/can? forge user "write" owner name)))) + +(define + gitea/w-api-issue-state + (fn + (forge req state) + (let + ((owner (dream-param req "owner")) + (name (dream-param req "name")) + (n (gitea/w-issue-n req))) + (let + ((user (gitea/w-user forge req))) + (cond + ((or (nil? n) (not (gitea/can? forge user "read" owner name))) + (dream-not-found)) + ((nil? user) (gitea/w-unauthorized)) + (else + (let + ((rec (gitea/issue-get forge owner name n))) + (cond + ((nil? rec) (dream-not-found)) + ((not (gitea/issue-can-close? forge user owner name rec)) + (gitea/w-forbidden)) + (else + (begin + (gitea/issue-update! + forge + owner + name + n + (fn (r) (assoc r :state state))) + (dream-json-value {:state state :number n}))))))))))) + +; label + assignee management requires write +(define + gitea/w-api-issue-edit + (fn + (forge req f) + (let + ((owner (dream-param req "owner")) + (name (dream-param req "name")) + (n (gitea/w-issue-n req))) + (let + ((user (gitea/w-user forge req))) + (cond + ((or (nil? n) (not (gitea/can? forge user "read" owner name))) + (dream-not-found)) + ((nil? user) (gitea/w-unauthorized)) + ((not (gitea/can? forge user "write" owner name)) + (gitea/w-forbidden)) + ((nil? (gitea/issue-get forge owner name n)) (dream-not-found)) + (else + (let + ((res (f owner name n))) + (if + (and (dict? res) (get res :error)) + (gitea/w-json-status 400 {:error (get res :error)}) + (dream-json-value {:number n}))))))))) + +(define + gitea/issue-routes + (fn + (forge) + (list + (dream-get + "/:owner/:name/issues" + (fn (req) (gitea/w-issues-page forge req))) + (dream-get + "/:owner/:name/issues/:n" + (fn (req) (gitea/w-issue-page forge req))) + (dream-get + "/api/repos/:owner/:name/issues" + (fn (req) (gitea/w-api-issues forge req))) + (dream-post + "/api/repos/:owner/:name/issues" + (fn (req) (gitea/w-api-issue-create forge req))) + (dream-post + "/api/repos/:owner/:name/issues/:n/comments" + (fn (req) (gitea/w-api-issue-comment forge req))) + (dream-post + "/api/repos/:owner/:name/issues/:n/close" + (fn (req) (gitea/w-api-issue-state forge req "closed"))) + (dream-post + "/api/repos/:owner/:name/issues/:n/reopen" + (fn (req) (gitea/w-api-issue-state forge req "open"))) + (dream-put + "/api/repos/:owner/:name/issues/:n/labels/:label" + (fn + (req) + (gitea/w-api-issue-edit + forge + req + (fn + (o r n) + (gitea/issue-label! forge o r n (dream-param req "label")))))) + (dream-delete + "/api/repos/:owner/:name/issues/:n/labels/:label" + (fn + (req) + (gitea/w-api-issue-edit + forge + req + (fn + (o r n) + (gitea/issue-unlabel! forge o r n (dream-param req "label")))))) + (dream-put + "/api/repos/:owner/:name/issues/:n/assignees/:user" + (fn + (req) + (gitea/w-api-issue-edit + forge + req + (fn + (o r n) + (gitea/issue-assign! forge o r n (dream-param req "user")))))) + (dream-delete + "/api/repos/:owner/:name/issues/:n/assignees/:user" + (fn + (req) + (gitea/w-api-issue-edit + forge + req + (fn + (o r n) + (gitea/issue-unassign! forge o r n (dream-param req "user"))))))))) + +(set! gitea/route-packs (append gitea/route-packs (list gitea/issue-routes))) diff --git a/lib/gitea/pr.sx b/lib/gitea/pr.sx new file mode 100644 index 00000000..01d72684 --- /dev/null +++ b/lib/gitea/pr.sx @@ -0,0 +1,808 @@ +; lib/gitea/pr.sx — sx-gitea Phase 5: pull requests. +; +; A PR is a kv record: source branch -> target branch, title/author/body +; (Markdown, rendered via content like issues), a review thread (latest +; verdict per reviewer wins), and a merge outcome. Numbers share the +; per-repo counter with issues (gitea/issue-next!), GitHub-style. +; +; The diff is always LIVE — computed with sx-git from the merge base of +; the current branch heads to the source head (so a target that moved on +; never shows spurious deletions), never stored. +; +; Lifecycle is a lib/flow durable workflow (deterministic-replay +; suspend): open -(approval)-> approved -(merge)-> merged. review! resumes +; the approval suspend when the verdict set first becomes approving; +; merge!/close! resume/cancel the rest. The flow env lives in the forge +; handle; the record's :state stays the source of truth (merge re-checks +; approval live — the flow is the durable journal of the lifecycle). +; +; Merging uses git/merge-commits (3-way over the merge base): up-to-date +; and fast-forward move nothing or just the ref; a true merge writes a +; two-parent commit; conflicts abort with the conflicting paths. All ref +; moves go through branch-cas! — a concurrent push surfaces as "stale". +; +; The merge queue is a per-repo list of approved PR numbers; +; queue-process! merges them in order, keeping the failures queued. +; +; Requires: lib/gitea/{repo,access,web,issues}.sx and their stacks, plus +; the flow stack (lib/guest/lex, lib/guest/reflective/{env,quoting}, +; lib/scheme/{parser,eval,runtime}, lib/flow/{spec,store,remote,host,api}). + +; ── record plumbing ────────────────────────────────────────────────── + +(define + gitea/pr-key + (fn (owner name n) (str "gitea/pr/" owner "/" name "/" (gitea/pad8 n)))) + +(define + gitea/pr-get + (fn + (forge owner name n) + (persist/kv-get (gitea/forge-db forge) (gitea/pr-key owner name n)))) + +(define + gitea/prs + (fn + (forge owner name) + (map + (fn (s) (parse-int s)) + (gitea/names-under forge (str "gitea/pr/" owner "/" name "/"))))) + +(define + gitea/pr-records + (fn + (forge owner name) + (map + (fn (n) (gitea/pr-get forge owner name n)) + (gitea/prs forge owner name)))) + +(define + gitea/pr-update! + (fn + (forge owner name n f) + (let + ((rec (gitea/pr-get forge owner name n))) + (if + (nil? rec) + nil + (persist/kv-put + (gitea/forge-db forge) + (gitea/pr-key owner name n) + (f rec)))))) + +; ── the lifecycle flow ─────────────────────────────────────────────── + +(define + gitea/pr-flow-src + "(defflow pr-lifecycle (sequence (flow-node (lambda (x) (suspend (quote approval)))) (flow-node (lambda (x) (suspend (quote merge)))) (flow-node (lambda (x) (quote merged)))))") + +(define + gitea/flow-env + (fn + (forge) + (let + ((cache (get forge :cache))) + (if + (and cache (get cache "flow-env")) + (get cache "flow-env") + (let + ((env (flow-make-env))) + (begin + (flow-run-in env gitea/pr-flow-src) + (if cache (dict-set! cache "flow-env" env) nil) + env)))))) + +; => flow id (int) | nil +(define + gitea/pr-flow-start! + (fn + (forge n) + (let + ((res (flow-run-in (gitea/flow-env forge) (str "(flow/start pr-lifecycle " n ")")))) + (if + (and (list? res) (>= (len res) 2)) + (nth res 1) + nil)))) + +(define + gitea/flow-pending-tag + (fn + (forge fid) + (let + ((pending (flow-run-in (gitea/flow-env forge) "(flow/pending)"))) + (reduce + (fn + (acc p) + (if + (and (list? p) (= (first p) fid)) + (str (nth p 1)) + acc)) + nil + pending)))) + +(define + gitea/pr-flow-resume! + (fn + (forge fid value) + (flow-run-in + (gitea/flow-env forge) + (str "(flow/resume " fid " (quote " value "))")))) + +(define + gitea/pr-flow-cancel! + (fn + (forge fid) + (flow-run-in (gitea/flow-env forge) (str "(flow/cancel " fid ")")))) + +; lifecycle stage as seen from the durable flow +(define + gitea/pr-flow-status + (fn + (forge rec) + (let + ((fid (get rec :flow-id))) + (if + (nil? fid) + "none" + (let + ((st (str (flow-run-in (gitea/flow-env forge) (str "(flow/status " fid ")"))))) + (cond + ((= st "done") "merged") + ((= st "cancelled") "closed") + ((= st "suspended") + (let + ((tag (gitea/flow-pending-tag forge fid))) + (cond + ((= tag "approval") "review") + ((= tag "merge") "approved") + (else "suspended")))) + (else st))))))) + +; ── create ─────────────────────────────────────────────────────────── + +(define + gitea/pr-create! + (fn + (forge owner name author title source target body opts) + (cond + ((not (gitea/repo-exists? forge owner name)) {:error "no-such-repo"}) + ((not (gitea/owner-exists? forge author)) {:error "no-such-user"}) + ((or (not (string? title)) (= title "")) {:error "empty-title"}) + ((= source target) {:error "same-branch"}) + (else + (let + ((grepo (gitea/repo-git forge owner name))) + (cond + ((nil? (git/branch-get grepo source)) {:error "no-such-source"}) + ((nil? (git/branch-get grepo target)) {:error "no-such-target"}) + (else + (let + ((o (or opts {}))) + (let + ((n (gitea/issue-next! forge owner name))) + (let + ((rec {:source source :state "open" :title title :merge-cid nil :reviews (list) :body (or body "") :number n :author author :created-at (or (get o :created-at) 0) :target target :flow-id (gitea/pr-flow-start! forge n)})) + (begin + (persist/kv-put + (gitea/forge-db forge) + (gitea/pr-key owner name n) + rec) + rec))))))))))) + +; ── live diff (merge base -> source head) ──────────────────────────── + +(define + gitea/pr-heads + (fn + (forge owner name rec) + (let + ((grepo (gitea/repo-git forge owner name))) + (let + ((tcid (git/branch-get grepo (get rec :target))) + (scid (git/branch-get grepo (get rec :source)))) + {:base-cid (if (or (nil? tcid) (nil? scid)) nil (or (git/merge-base grepo tcid scid) tcid)) :grepo grepo :target-cid tcid :source-cid scid})))) + +; {:added :modified :deleted} from the merge base to the source head +(define + gitea/pr-diff + (fn + (forge owner name n) + (let + ((rec (gitea/pr-get forge owner name n))) + (if + (nil? rec) + nil + (let + ((h (gitea/pr-heads forge owner name rec))) + (if + (or (nil? (get h :base-cid)) (nil? (get h :source-cid))) + nil + (git/commit-diff + (get h :grepo) + (get h :base-cid) + (get h :source-cid)))))))) + +(define + gitea/pr-diff-unified + (fn + (forge owner name n) + (let + ((rec (gitea/pr-get forge owner name n))) + (if + (nil? rec) + nil + (let + ((h (gitea/pr-heads forge owner name rec))) + (if + (or (nil? (get h :base-cid)) (nil? (get h :source-cid))) + nil + (git/commit-diff-unified + (get h :grepo) + (get h :base-cid) + (get h :source-cid)))))))) + +; ── reviews ────────────────────────────────────────────────────────── + +(define gitea/pr-verdicts (list "approve" "request-changes")) + +; latest verdict per reviewer +(define + gitea/pr-latest-verdicts + (fn + (rec) + (reduce + (fn (acc r) (assoc acc (get r :reviewer) (get r :verdict))) + {} + (get rec :reviews)))) + +(define + gitea/pr-approved? + (fn + (rec) + (let + ((latest (gitea/pr-latest-verdicts rec))) + (let + ((vs (map (fn (k) (get latest k)) (keys latest)))) + (and + (contains? vs "approve") + (not (contains? vs "request-changes"))))))) + +; resume the approval suspend the first time the verdict set approves +(define + gitea/pr-sync-flow! + (fn + (forge owner name n) + (let + ((rec (gitea/pr-get forge owner name n))) + (if + (and + rec + (gitea/pr-approved? rec) + (not (nil? (get rec :flow-id))) + (= (gitea/flow-pending-tag forge (get rec :flow-id)) "approval")) + (begin + (gitea/pr-flow-resume! forge (get rec :flow-id) "approved") + true) + false)))) + +(define + gitea/pr-review! + (fn + (forge owner name n reviewer verdict body opts) + (let + ((rec (gitea/pr-get forge owner name n))) + (cond + ((nil? rec) {:error "no-such-pr"}) + ((not (= (get rec :state) "open")) {:error "not-open"}) + ((not (gitea/owner-exists? forge reviewer)) {:error "no-such-user"}) + ((= reviewer (get rec :author)) {:error "own-pr"}) + ((not (contains? gitea/pr-verdicts verdict)) {:error "invalid-verdict"}) + (else + (let + ((review {:verdict verdict :body (or body "") :at (or (get (or opts {}) :at) 0) :reviewer reviewer})) + (begin + (gitea/pr-update! + forge + owner + name + n + (fn + (r) + (assoc r :reviews (append (get r :reviews) (list review))))) + (gitea/pr-sync-flow! forge owner name n) + review))))))) + +; ── merge ──────────────────────────────────────────────────────────── + +(define + gitea/pr-mark-merged! + (fn + (forge owner name n cid) + (let + ((rec (gitea/pr-update! forge owner name n (fn (r) (assoc (assoc r :state "merged") :merge-cid cid))))) + (begin + (if + (and + rec + (not (nil? (get rec :flow-id))) + (= (gitea/flow-pending-tag forge (get rec :flow-id)) "merge")) + (gitea/pr-flow-resume! forge (get rec :flow-id) "merged") + nil) + rec)))) + +(define + gitea/pr-merge! + (fn + (forge owner name n merger opts) + (let + ((rec (gitea/pr-get forge owner name n))) + (cond + ((nil? rec) {:error "no-such-pr"}) + ((not (= (get rec :state) "open")) {:error "not-open"}) + ((not (gitea/pr-approved? rec)) {:error "not-approved"}) + (else + (let + ((h (gitea/pr-heads forge owner name rec))) + (let + ((grepo (get h :grepo)) + (tcid (get h :target-cid)) + (scid (get h :source-cid))) + (cond + ((or (nil? tcid) (nil? scid)) {:error "missing-branch"}) + (else + (let + ((m (git/merge-commits grepo tcid scid))) + (cond + ((= (get m :result) "up-to-date") + (gitea/pr-mark-merged! forge owner name n tcid)) + ((= (get m :result) "fast-forward") + (let + ((res (git/branch-cas! grepo (get rec :target) tcid scid))) + (if + (and (dict? res) (get res :conflict)) + {:error "stale"} + (gitea/pr-mark-merged! forge owner name n scid)))) + ((= (get m :result) "merged") + (let + ((mc (git/write grepo (git/commit (get m :tree) (list tcid scid) {:message (str "Merge PR #" n ": " (get rec :title)) :time (or (get (or opts {}) :time) 0) :author (or merger "")})))) + (let + ((res (git/branch-cas! grepo (get rec :target) tcid mc))) + (if + (and (dict? res) (get res :conflict)) + {:error "stale"} + (gitea/pr-mark-merged! forge owner name n mc))))) + (else {:conflicts (get m :conflicts) :error "conflicts"})))))))))))) + +; ── close / reopen ─────────────────────────────────────────────────── + +(define + gitea/pr-close! + (fn + (forge owner name n) + (let + ((rec (gitea/pr-get forge owner name n))) + (if + (or (nil? rec) (not (= (get rec :state) "open"))) + nil + (begin + (if + (nil? (get rec :flow-id)) + nil + (gitea/pr-flow-cancel! forge (get rec :flow-id))) + (gitea/pr-update! + forge + owner + name + n + (fn (r) (assoc r :state "closed")))))))) + +; reopening restarts the lifecycle (a cancelled flow cannot resume) +(define + gitea/pr-reopen! + (fn + (forge owner name n) + (let + ((rec (gitea/pr-get forge owner name n))) + (if + (or (nil? rec) (not (= (get rec :state) "closed"))) + nil + (gitea/pr-update! + forge + owner + name + n + (fn + (r) + (assoc + (assoc r :state "open") + :flow-id (gitea/pr-flow-start! forge n)))))))) + +; ── merge queue ────────────────────────────────────────────────────── + +(define + gitea/queue-key + (fn (owner name) (str "gitea/mergeq/" owner "/" name))) + +(define + gitea/queue + (fn + (forge owner name) + (persist/kv-get-or + (gitea/forge-db forge) + (gitea/queue-key owner name) + (list)))) + +(define + gitea/queue-add! + (fn + (forge owner name n) + (let + ((rec (gitea/pr-get forge owner name n))) + (cond + ((nil? rec) {:error "no-such-pr"}) + ((not (= (get rec :state) "open")) {:error "not-open"}) + ((not (gitea/pr-approved? rec)) {:error "not-approved"}) + (else + (let + ((q (gitea/queue forge owner name))) + (if + (contains? q n) + q + (persist/kv-put + (gitea/forge-db forge) + (gitea/queue-key owner name) + (append q (list n)))))))))) + +(define + gitea/queue-remove! + (fn + (forge owner name n) + (persist/kv-put + (gitea/forge-db forge) + (gitea/queue-key owner name) + (filter (fn (x) (not (= x n))) (gitea/queue forge owner name))))) + +; merge queued PRs in order; merged ones leave the queue, failures stay +; => ({:number n :merged true} | {:number n :error reason} ...) +(define + gitea/queue-process! + (fn + (forge owner name merger) + (let + ((results (map (fn (n) (let ((res (gitea/pr-merge! forge owner name n merger {}))) (if (get res :error) {:error (get res :error) :number n} {:merged true :number n}))) (gitea/queue forge owner name)))) + (begin + (persist/kv-put + (gitea/forge-db forge) + (gitea/queue-key owner name) + (map + (fn (r) (get r :number)) + (filter (fn (r) (get r :error)) results))) + results)))) + +; ── web ────────────────────────────────────────────────────────────── + +(define + gitea/w-pr-item + (fn + (owner name r) + (str + "
  • #" + (get r :number) + " " + (dream-escape (get r :title)) + " [" + (get r :state) + "] " + (dream-escape (get r :source)) + " -> " + (dream-escape (get r :target)) + "
  • "))) + +(define + gitea/w-pulls-page + (fn + (forge req) + (let + ((owner (dream-param req "owner")) (name (dream-param req "name"))) + (if + (not (gitea/w-readable? forge req owner name)) + (dream-not-found) + (gitea/w-page + (str owner "/" name " pull requests") + (str + "

    Pull Requests

      " + (join + "" + (map + (fn (r) (gitea/w-pr-item owner name r)) + (gitea/pr-records forge owner name))) + "
    ")))))) + +(define + gitea/w-review-html + (fn + (owner name n i r) + (str + "

    " + (dream-escape (get r :reviewer)) + ": " + (get r :verdict) + "

    " + (gitea/md-html (get r :body) (str "rv-" owner "-" name "-" n "-" i)) + "
    "))) + +(define + gitea/w-pull-page + (fn + (forge req) + (let + ((owner (dream-param req "owner")) + (name (dream-param req "name")) + (n (gitea/w-issue-n req))) + (if + (or (nil? n) (not (gitea/w-readable? forge req owner name))) + (dream-not-found) + (let + ((rec (gitea/pr-get forge owner name n))) + (if + (nil? rec) + (dream-not-found) + (gitea/w-page + (str "#" n " " (get rec :title)) + (str + "

    #" + n + " " + (dream-escape (get rec :title)) + "

    " + "

    " + (get rec :state) + "

    " + "

    " + (dream-escape (get rec :source)) + " -> " + (dream-escape (get rec :target)) + "

    " + "

    " + (gitea/pr-flow-status forge rec) + "

    " + "
    " + (gitea/md-html + (get rec :body) + (str "pr-" owner "-" name "-" n)) + "
    " + "

    Reviews

    " + (join + "" + (map-indexed + (fn (i r) (gitea/w-review-html owner name n i r)) + (get rec :reviews))) + "

    Diff

    "
    +                (dream-escape
    +                  (or (gitea/pr-diff-unified forge owner name n) ""))
    +                "
    ")))))))) + +; ── json api ───────────────────────────────────────────────────────── + +(define + gitea/w-api-pulls + (fn + (forge req) + (let + ((owner (dream-param req "owner")) (name (dream-param req "name"))) + (if + (not (gitea/w-readable? forge req owner name)) + (dream-not-found) + (dream-json-value + (map (fn (r) {:source (get r :source) :state (get r :state) :title (get r :title) :number (get r :number) :target (get r :target)}) (gitea/pr-records forge owner name))))))) + +(define + gitea/w-api-pr-create + (fn + (forge req) + (let + ((owner (dream-param req "owner")) (name (dream-param req "name"))) + (let + ((user (gitea/w-user forge req))) + (cond + ((not (gitea/can? forge user "read" owner name)) + (if + (nil? user) + (if + (and + (gitea/repo-exists? forge owner name) + (equal? + (get (gitea/repo-get forge owner name) :visibility) + "public")) + (gitea/w-unauthorized) + (dream-not-found)) + (dream-not-found))) + ((nil? user) (gitea/w-unauthorized)) + (else + (let + ((body (dream-json-body req))) + (let + ((res (gitea/pr-create! forge owner name user (get body :title) (get body :source) (get body :target) (or (get body :body) "") {:created-at (or (get body :created-at) 0)}))) + (if + (get res :error) + (gitea/w-json-status 400 {:error (get res :error)}) + (gitea/w-json-status 201 {:title (get res :title) :number (get res :number)})))))))))) + +(define + gitea/w-api-pr-review + (fn + (forge req) + (let + ((owner (dream-param req "owner")) + (name (dream-param req "name")) + (n (gitea/w-issue-n req))) + (let + ((user (gitea/w-user forge req))) + (cond + ((or (nil? n) (not (gitea/can? forge user "read" owner name))) + (dream-not-found)) + ((nil? user) (gitea/w-unauthorized)) + (else + (let + ((body (dream-json-body req))) + (let + ((res (gitea/pr-review! forge owner name n user (get body :verdict) (or (get body :body) "") {:at (or (get body :created-at) 0)}))) + (cond + ((equal? (get res :error) "no-such-pr") (dream-not-found)) + ((get res :error) + (gitea/w-json-status 400 {:error (get res :error)})) + (else (dream-json-value {:verdict (get res :verdict) :reviewer user}))))))))))) + +(define + gitea/w-api-pr-merge + (fn + (forge req) + (let + ((owner (dream-param req "owner")) + (name (dream-param req "name")) + (n (gitea/w-issue-n req))) + (let + ((user (gitea/w-user forge req))) + (cond + ((or (nil? n) (not (gitea/can? forge user "read" owner name))) + (dream-not-found)) + ((nil? user) (gitea/w-unauthorized)) + ((not (gitea/can? forge user "write" owner name)) + (gitea/w-forbidden)) + (else + (let + ((res (gitea/pr-merge! forge owner name n user {:time (or (get (dream-json-body req) :time) 0)}))) + (cond + ((equal? (get res :error) "no-such-pr") (dream-not-found)) + ((get res :error) + (gitea/w-json-status 409 {:error (get res :error)})) + (else (dream-json-value {:state (get res :state) :merge-cid (get res :merge-cid) :number n})))))))))) + +(define + gitea/w-api-pr-close + (fn + (forge req) + (let + ((owner (dream-param req "owner")) + (name (dream-param req "name")) + (n (gitea/w-issue-n req))) + (let + ((user (gitea/w-user forge req))) + (cond + ((or (nil? n) (not (gitea/can? forge user "read" owner name))) + (dream-not-found)) + ((nil? user) (gitea/w-unauthorized)) + (else + (let + ((rec (gitea/pr-get forge owner name n))) + (cond + ((nil? rec) (dream-not-found)) + ((not (or (= user (get rec :author)) (gitea/can? forge user "write" owner name))) + (gitea/w-forbidden)) + (else + (let + ((res (gitea/pr-close! forge owner name n))) + (if + (nil? res) + (gitea/w-json-status 409 {:error "not-open"}) + (dream-json-value {:state "closed" :number n})))))))))))) + +(define + gitea/w-api-queue + (fn + (forge req) + (let + ((owner (dream-param req "owner")) (name (dream-param req "name"))) + (if + (not (gitea/w-readable? forge req owner name)) + (dream-not-found) + (dream-json-value (gitea/queue forge owner name)))))) + +(define + gitea/w-api-queue-add + (fn + (forge req) + (let + ((owner (dream-param req "owner")) + (name (dream-param req "name")) + (n (gitea/w-issue-n req))) + (let + ((user (gitea/w-user forge req))) + (cond + ((or (nil? n) (not (gitea/can? forge user "read" owner name))) + (dream-not-found)) + ((nil? user) (gitea/w-unauthorized)) + ((not (gitea/can? forge user "write" owner name)) + (gitea/w-forbidden)) + (else + (let + ((res (gitea/queue-add! forge owner name n))) + (if + (and (dict? res) (get res :error)) + (gitea/w-json-status 409 {:error (get res :error)}) + (dream-json-value (gitea/queue forge owner name)))))))))) + +(define + gitea/w-api-queue-process + (fn + (forge req) + (let + ((owner (dream-param req "owner")) (name (dream-param req "name"))) + (let + ((user (gitea/w-user forge req))) + (cond + ((not (gitea/can? forge user "read" owner name)) + (dream-not-found)) + ((nil? user) (gitea/w-unauthorized)) + ((not (gitea/can? forge user "write" owner name)) + (gitea/w-forbidden)) + (else + (dream-json-value (gitea/queue-process! forge owner name user)))))))) + +(define + gitea/pr-routes + (fn + (forge) + (list + (dream-get + "/:owner/:name/pulls" + (fn (req) (gitea/w-pulls-page forge req))) + (dream-get + "/:owner/:name/pulls/:n" + (fn (req) (gitea/w-pull-page forge req))) + (dream-get + "/api/repos/:owner/:name/pulls" + (fn (req) (gitea/w-api-pulls forge req))) + (dream-post + "/api/repos/:owner/:name/pulls" + (fn (req) (gitea/w-api-pr-create forge req))) + (dream-post + "/api/repos/:owner/:name/pulls/:n/reviews" + (fn (req) (gitea/w-api-pr-review forge req))) + (dream-post + "/api/repos/:owner/:name/pulls/:n/merge" + (fn (req) (gitea/w-api-pr-merge forge req))) + (dream-post + "/api/repos/:owner/:name/pulls/:n/close" + (fn (req) (gitea/w-api-pr-close forge req))) + (dream-get + "/api/repos/:owner/:name/merge-queue" + (fn (req) (gitea/w-api-queue forge req))) + (dream-post + "/api/repos/:owner/:name/pulls/:n/enqueue" + (fn (req) (gitea/w-api-queue-add forge req))) + (dream-post + "/api/repos/:owner/:name/merge-queue/process" + (fn (req) (gitea/w-api-queue-process forge req)))))) + +(set! gitea/route-packs (append gitea/route-packs (list gitea/pr-routes))) diff --git a/lib/gitea/repo.sx b/lib/gitea/repo.sx new file mode 100644 index 00000000..ee9a1364 --- /dev/null +++ b/lib/gitea/repo.sx @@ -0,0 +1,270 @@ +; lib/gitea/repo.sx — sx-gitea Phase 1: forge core. +; +; The forge is a handle over a persist backend. Owner principals and repo +; records live in the kv store under "gitea/..."; each repo's git objects +; and refs live in their own git/repo-named namespace "forge//", +; so deleting a repo is a prefix purge and repos are invisible to each other. +; Owner principals are a lightweight directory here; Phase 2 (access) backs +; them with identity users/orgs. +; +; Requires: lib/persist/{event,backend,log,kv}.sx, lib/artdag/dag.sx, +; lib/git/{object,ref,dag,worktree,diff,merge,porcelain}.sx + +(define gitea/forge (fn (db) {:cache {} :db db})) +(define gitea/forge-db (fn (forge) (get forge :db))) + +; ── names ──────────────────────────────────────────────────────────── +; Owner and repo names share one rule: nonempty, no "/" or spaces, and not +; a word the router owns (an owner called "api" would shadow /api routes). + +(define + gitea/reserved-names + (list "api" "tree" "blob" "raw" "commit" "commits" "branches")) + +(define + gitea/valid-name? + (fn + (name) + (and + (string? name) + (> (string-length name) 0) + (not (contains? name "/")) + (not (contains? name " ")) + (not (contains? gitea/reserved-names name))))) + +; ── owners ─────────────────────────────────────────────────────────── + +(define gitea/owner-key (fn (name) (str "gitea/owner/" name))) + +(define + gitea/owner-get + (fn + (forge name) + (persist/kv-get (gitea/forge-db forge) (gitea/owner-key name)))) + +(define + gitea/owner-exists? + (fn + (forge name) + (persist/kv-has? (gitea/forge-db forge) (gitea/owner-key name)))) + +(define + gitea/owner-create! + (fn + (forge kind name) + (if + (not (gitea/valid-name? name)) + {:name name :error "invalid-name"} + (persist/kv-put-new + (gitea/forge-db forge) + (gitea/owner-key name) + {:name name :kind kind})))) + +(define + gitea/user-create! + (fn (forge name) (gitea/owner-create! forge "user" name))) +(define + gitea/org-create! + (fn (forge name) (gitea/owner-create! forge "org" name))) + +(define gitea/user? (fn (owner) (equal? (get owner :kind) "user"))) +(define gitea/org? (fn (owner) (equal? (get owner :kind) "org"))) + +(define + gitea/names-under + (fn + (forge pfx) + (artdag/sort-strings + (map + (fn (k) (substr k (string-length pfx))) + (filter + (fn (k) (starts-with? k pfx)) + (persist/kv-keys (gitea/forge-db forge))))))) + +(define gitea/owners (fn (forge) (gitea/names-under forge "gitea/owner/"))) + +; ── repo records ───────────────────────────────────────────────────── + +(define gitea/repo-key (fn (owner name) (str "gitea/repo/" owner "/" name))) +(define gitea/repo-ns (fn (owner name) (str "forge/" owner "/" name))) + +(define gitea/repo-record (fn (owner name opts) {:name name :description (or (get opts :description) "") :default-branch (or (get opts :default-branch) "main") :owner owner :created-at (or (get opts :created-at) 0) :visibility (or (get opts :visibility) "public")})) + +; create-only: {:error ...} on bad input, {:conflict ...} if it exists, +; else initialize the git store (HEAD -> unborn heads/main) and return +; the record. +(define + gitea/repo-create! + (fn + (forge owner name opts) + (cond + ((not (gitea/owner-exists? forge owner)) {:error "no-such-owner" :owner owner}) + ((not (gitea/valid-name? name)) {:name name :error "invalid-name"}) + (else + (let + ((rec (gitea/repo-record owner name (or opts {})))) + (let + ((res (persist/kv-put-new (gitea/forge-db forge) (gitea/repo-key owner name) rec))) + (if + (get res :conflict) + res + (begin + (git/init! (gitea/forge-db forge) (gitea/repo-ns owner name)) + rec)))))))) + +(define + gitea/repo-get + (fn + (forge owner name) + (persist/kv-get (gitea/forge-db forge) (gitea/repo-key owner name)))) + +(define + gitea/repo-exists? + (fn + (forge owner name) + (persist/kv-has? (gitea/forge-db forge) (gitea/repo-key owner name)))) + +(define + gitea/repo-update! + (fn + (forge owner name f) + (let + ((rec (gitea/repo-get forge owner name))) + (if + (nil? rec) + nil + (persist/kv-put + (gitea/forge-db forge) + (gitea/repo-key owner name) + (f rec)))))) + +; the sx-git handle for a repo's own object/ref namespace +(define + gitea/repo-git + (fn + (forge owner name) + (git/repo-named (gitea/forge-db forge) (gitea/repo-ns owner name)))) + +; everything owned by a repo record, beyond the record itself: its git +; namespace and any per-repo rows other phases hang off it +(define + gitea/repo-purge-prefixes + (fn + (owner name) + (list + (str (gitea/repo-ns owner name) "/") + (str "gitea/collab/" owner "/" name "/") + (str "gitea/issue/" owner "/" name "/")))) + +(define + gitea/repo-purge-keys + (fn (owner name) (list (str "gitea/issue-seq/" owner "/" name)))) + +; delete the record and purge every key the repo owns — a recreated repo +; under the same name must start truly empty (no ghost collaborators, +; issues, or objects) +(define + gitea/repo-delete! + (fn + (forge owner name) + (if + (not (gitea/repo-exists? forge owner name)) + false + (let + ((db (gitea/forge-db forge)) + (prefixes (gitea/repo-purge-prefixes owner name))) + (begin + (for-each + (fn + (k) + (if + (reduce + (fn (acc p) (or acc (starts-with? k p))) + false + prefixes) + (persist/kv-delete db k) + nil)) + (persist/kv-keys db)) + (for-each + (fn (k) (persist/kv-delete db k)) + (gitea/repo-purge-keys owner name)) + (persist/kv-delete db (gitea/repo-key owner name)) + true))))) + +(define gitea/repos (fn (forge) (gitea/names-under forge "gitea/repo/"))) + +(define + gitea/repos-for + (fn (forge owner) (gitea/names-under forge (str "gitea/repo/" owner "/")))) + +; ── ref resolution / tree navigation (shared by browse views) ──────── + +; follow annotated tag objects down to the commit they name +(define + gitea/peel-to-commit + (fn + (grepo cid) + (let + ((obj (git/read grepo cid))) + (cond + ((nil? obj) nil) + ((git/tag? obj) (gitea/peel-to-commit grepo (git/tag-target obj))) + (else cid))))) + +; a browse ref is a branch name, a tag name, or a raw cid — in that order +(define + gitea/resolve-ref + (fn + (grepo refname) + (let + ((b (git/branch-get grepo refname))) + (if + b + (gitea/peel-to-commit grepo b) + (let + ((t (git/tag-get grepo refname))) + (if + t + (gitea/peel-to-commit grepo t) + (if + (git/has? grepo refname) + (gitea/peel-to-commit grepo refname) + nil))))))) + +(define + gitea/path-segs + (fn (path) (filter (fn (s) (not (equal? s ""))) (split path "/")))) + +; walk tree entries by path segments => {:kind "tree"|"blob" :cid cid} | nil +(define + gitea/entry-at + (fn + (grepo tree-cid segs) + (if + (empty? segs) + {:kind "tree" :cid tree-cid} + (let + ((tree (git/read grepo tree-cid))) + (if + (not (git/tree? tree)) + nil + (let + ((entry (git/tree-entry-for tree (first segs)))) + (cond + ((nil? entry) nil) + ((empty? (rest segs)) {:kind (git/entry-kind entry) :cid (git/entry-cid entry)}) + ((equal? (git/entry-kind entry) "tree") + (gitea/entry-at grepo (git/entry-cid entry) (rest segs))) + (else nil)))))))) + +; entry at path under a COMMIT's tree ("" => the root tree) +(define + gitea/tree-at + (fn + (grepo commit-cid path) + (let + ((c (git/read grepo commit-cid))) + (if + (not (git/commit? c)) + nil + (gitea/entry-at grepo (git/commit-tree c) (gitea/path-segs path)))))) diff --git a/lib/gitea/scoreboard.json b/lib/gitea/scoreboard.json new file mode 100644 index 00000000..b949e667 --- /dev/null +++ b/lib/gitea/scoreboard.json @@ -0,0 +1,15 @@ +{ + "suites": { + "repo": {"pass": 91, "fail": 0}, + "access": {"pass": 103, "fail": 0}, + "wire": {"pass": 78, "fail": 0}, + "issues": {"pass": 88, "fail": 0}, + "pr": {"pass": 100, "fail": 0}, + "activity": {"pass": 60, "fail": 0}, + "search": {"pass": 35, "fail": 0}, + "fed": {"pass": 60, "fail": 0} + }, + "total_pass": 615, + "total_fail": 0, + "total": 615 +} diff --git a/lib/gitea/scoreboard.md b/lib/gitea/scoreboard.md new file mode 100644 index 00000000..7da60b68 --- /dev/null +++ b/lib/gitea/scoreboard.md @@ -0,0 +1,15 @@ +# sx-gitea Conformance Scoreboard + +_Generated by `lib/gitea/conformance.sh`_ + +| Suite | Pass | Fail | Total | +|-------|-----:|-----:|------:| +| repo | 91 | 0 | 91 | +| access | 103 | 0 | 103 | +| wire | 78 | 0 | 78 | +| issues | 88 | 0 | 88 | +| pr | 100 | 0 | 100 | +| activity | 60 | 0 | 60 | +| search | 35 | 0 | 35 | +| fed | 60 | 0 | 60 | +| **Total** | **615** | **0** | **615** | diff --git a/lib/gitea/search.sx b/lib/gitea/search.sx new file mode 100644 index 00000000..62a7e28d --- /dev/null +++ b/lib/gitea/search.sx @@ -0,0 +1,383 @@ +; lib/gitea/search.sx — sx-gitea Phase 7: code + issue/PR search. +; +; search-on-sx (haskell-on-sx) does the heavy lifting: the forge builds a +; document corpus SX-side — code files from the default branch head +; (path + blob text), issues (title + body + comment bodies), PRs (title +; + body + review bodies) — embeds it as one Haskell program, and asks +; searchRankTfIdf for ranked doc ids. Queries speak the search query +; language (terms, AND/OR/NOT, "phrases"). +; +; Cost model: ONE evaluation parses the Haskell search layers (~seconds), +; extra queries are nearly free. So the core primitive is +; gitea/search-multi — ANY number of corpora and queries in a single +; evaluation (each corpus becomes an idxN binding) — and everything else +; sugars over it. Only the six layers searchRankTfIdf needs are compiled +; (tokenize/index/query/parse/rank/rankq), not the full search/src. +; +; Requires: lib/gitea/{repo,access,web,issues,pr}.sx and their stacks, +; lib/haskell/* + lib/search/{tokenize,index,query,parse,rank,rankq, +; testlib}.sx (search-hk->sx, hk-core, hk-eval-program). + +; ── corpus ─────────────────────────────────────────────────────────── + +(define + gitea/code-docs + (fn + (forge owner name) + (let + ((rec (gitea/repo-get forge owner name))) + (if + (nil? rec) + (list) + (let + ((grepo (gitea/repo-git forge owner name))) + (let + ((head-cid (git/branch-get grepo (get rec :default-branch)))) + (if + (nil? head-cid) + (list) + (let + ((files (git/commit-files grepo head-cid))) + (map + (fn (p) {:text (str p " " (get files p)) :kind "code" :ref p}) + (artdag/sort-strings (keys files))))))))))) + +(define + gitea/issue-docs + (fn + (forge owner name) + (map (fn (r) {:text (str (get r :title) " " (get r :body) " " (join " " (map (fn (c) (get c :body)) (get r :comments)))) :kind "issue" :ref (str (get r :number))}) (gitea/issue-records forge owner name)))) + +(define + gitea/pr-search-docs + (fn + (forge owner name) + (map (fn (r) {:text (str (get r :title) " " (get r :body) " " (join " " (map (fn (v) (get v :body)) (get r :reviews)))) :kind "pr" :ref (str (get r :number))}) (gitea/pr-records forge owner name)))) + +(define gitea/search-kinds-all (list "code" "issue" "pr")) + +(define + gitea/repo-docs + (fn + (forge owner name kinds) + (filter + (fn (d) (contains? kinds (get d :kind))) + (concat + (gitea/code-docs forge owner name) + (concat + (gitea/issue-docs forge owner name) + (gitea/pr-search-docs forge owner name)))))) + +(define + gitea/visible-docs + (fn + (forge user kinds) + (reduce + (fn + (acc full) + (let + ((p (gitea/split-full full))) + (concat + acc + (map + (fn (d) (assoc d :repo full)) + (gitea/repo-docs forge (get p :owner) (get p :name) kinds))))) + (list) + (gitea/visible-repos forge user)))) + +; ── haskell program assembly ───────────────────────────────────────── + +; only the layers searchRankTfIdf needs — parsing is the dominant cost +(define + gitea/search-src + (str + search/tokenize-src + "\n" + search/index-src + "\n" + search/query-src + "\n" + search/parse-src + "\n" + search/rank-src + "\n" + search/rankq-src + "\n")) + +(define + gitea/hk-escape + (fn + (s) + (replace + (replace (replace (replace (or s "") "\\" "\\\\") "\"" "\\\"") "\n" "\\n") + "\t" + "\\t"))) + +; = indexDoc k "text_k" ( ... (indexDoc 1 "text_1" emptyIndex)) +(define + gitea/index-binding + (fn + (idxname docs) + (str + idxname + " = " + (reduce + (fn + (acc pair) + (str + "indexDoc " + (first pair) + " \"" + (gitea/hk-escape (get (nth pair 1) :text)) + "\" (" + acc + ")")) + "emptyIndex" + (map-indexed (fn (i d) (list (+ i 1) d)) docs)) + "\n"))) + +(define + gitea/hk-search-eval + (fn + (extra) + (search-hk->sx + (hk-deep-force + (get + (hk-eval-program (hk-core (str gitea/search-src extra))) + "result"))))) + +; THE core: corpora = (docs ...), specs = ({:corpus i :query q :n n} ...). +; One haskell evaluation; => one ranked {:kind :ref (:repo)} list per spec. +(define + gitea/search-multi + (fn + (corpora specs) + (let + ((bindings (join "" (map-indexed (fn (i docs) (gitea/index-binding (str "idx" i) docs)) corpora))) + (exprs + (map + (fn + (s) + (if + (empty? (nth corpora (get s :corpus))) + "[]" + (str + "take " + (get s :n) + " (searchRankTfIdf \"" + (gitea/hk-escape (get s :query)) + "\" idx" + (get s :corpus) + ")"))) + specs))) + (let + ((id-lists (gitea/hk-search-eval (str bindings "result = [" (join ", " exprs) "]\n")))) + (map-indexed + (fn + (si ids) + (let + ((docs (nth corpora (get (nth specs si) :corpus)))) + (map + (fn + (i) + (let + ((d (nth docs (- i 1)))) + (if (get d :repo) {:repo (get d :repo) :kind (get d :kind) :ref (get d :ref)} {:kind (get d :kind) :ref (get d :ref)}))) + ids))) + id-lists))))) + +; many queries against ONE corpus, still one evaluation +(define + gitea/search-many + (fn + (docs queries n) + (if + (empty? docs) + (map (fn (q) (list)) queries) + (gitea/search-multi (list docs) (map (fn (q) {:n n :query q :corpus 0}) queries))))) + +; ── repo-scoped search ─────────────────────────────────────────────── + +(define + gitea/search-repo + (fn + (forge owner name query kinds n) + (first + (gitea/search-many + (gitea/repo-docs forge owner name kinds) + (list query) + n)))) + +(define + gitea/search-code + (fn + (forge owner name query n) + (gitea/search-repo forge owner name query (list "code") n))) + +(define + gitea/search-issues + (fn + (forge owner name query n) + (gitea/search-repo forge owner name query (list "issue") n))) + +(define + gitea/search-prs + (fn + (forge owner name query n) + (gitea/search-repo forge owner name query (list "pr") n))) + +; ── global search over visible repos ───────────────────────────────── + +(define + gitea/search-visible + (fn + (forge user query kinds n) + (first + (gitea/search-many + (gitea/visible-docs forge user kinds) + (list query) + n)))) + +; ── web ────────────────────────────────────────────────────────────── + +(define gitea/w-query-param (fn (req name) (get (get req :query) name))) + +(define + gitea/w-search-kinds + (fn + (req) + (let + ((k (gitea/w-query-param req "kind"))) + (if + (contains? gitea/search-kinds-all k) + (list k) + gitea/search-kinds-all)))) + +(define + gitea/w-search-item + (fn + (owner name r) + (let + ((kind (get r :kind)) (ref (get r :ref))) + (cond + ((= kind "code") + (str + "
  • " + (dream-escape ref) + "
  • ")) + ((= kind "issue") + (str + "
  • #" + ref + "
  • ")) + (else + (str + "
  • #" + ref + "
  • ")))))) + +(define + gitea/w-search-page + (fn + (forge req) + (let + ((owner (dream-param req "owner")) + (name (dream-param req "name")) + (q (gitea/w-query-param req "q"))) + (cond + ((not (gitea/w-readable? forge req owner name)) (dream-not-found)) + ((or (nil? q) (= q "")) + (gitea/w-json-status 400 {:error "missing-query"})) + (else + (gitea/w-page + (str "search: " q) + (str + "

    Search

    " + (dream-escape q) + "

      " + (join + "" + (map + (fn (r) (gitea/w-search-item owner name r)) + (gitea/search-repo + forge + owner + name + q + (gitea/w-search-kinds req) + 20))) + "
    "))))))) + +(define + gitea/w-api-search-repo + (fn + (forge req) + (let + ((owner (dream-param req "owner")) + (name (dream-param req "name")) + (q (gitea/w-query-param req "q"))) + (cond + ((not (gitea/w-readable? forge req owner name)) (dream-not-found)) + ((or (nil? q) (= q "")) + (gitea/w-json-status 400 {:error "missing-query"})) + (else + (dream-json-value + (gitea/search-repo + forge + owner + name + q + (gitea/w-search-kinds req) + 20))))))) + +(define + gitea/w-api-search + (fn + (forge req) + (let + ((q (gitea/w-query-param req "q"))) + (if + (or (nil? q) (= q "")) + (gitea/w-json-status 400 {:error "missing-query"}) + (dream-json-value + (gitea/search-visible + forge + (gitea/w-user forge req) + q + (gitea/w-search-kinds req) + 20)))))) + +(define + gitea/search-routes + (fn + (forge) + (list + (dream-get + "/:owner/:name/search" + (fn (req) (gitea/w-search-page forge req))) + (dream-get + "/api/repos/:owner/:name/search" + (fn (req) (gitea/w-api-search-repo forge req))) + (dream-get "/api/search" (fn (req) (gitea/w-api-search forge req)))))) + +(set! + gitea/route-packs + (append gitea/route-packs (list gitea/search-routes))) diff --git a/lib/gitea/tests/access.sx b/lib/gitea/tests/access.sx new file mode 100644 index 00000000..238fb04a --- /dev/null +++ b/lib/gitea/tests/access.sx @@ -0,0 +1,546 @@ +; lib/gitea/tests/access.sx — Phase 2: visibility, collaborators, org +; teams, acl-backed can?, tokens, and auth-gated web routes. + +(define gitea-access-pass 0) +(define gitea-access-fail 0) +(define gitea-access-fails (list)) + +(define + gitea-access-test + (fn + (name actual expected) + (if + (= actual expected) + (set! gitea-access-pass (+ gitea-access-pass 1)) + (begin + (set! gitea-access-fail (+ gitea-access-fail 1)) + (set! + gitea-access-fails + (append gitea-access-fails (list {:name name :expected (inspect expected) :actual (inspect actual)}))))))) + +(define ga-db (persist/mem-backend)) +(define ga-forge (gitea/forge ga-db)) + +(gitea/user-create! ga-forge "alice") +(gitea/user-create! ga-forge "bob") +(gitea/user-create! ga-forge "carol") +(gitea/user-create! ga-forge "eve") +(gitea/org-create! ga-forge "acme") + +(gitea/repo-create! ga-forge "alice" "pub" {}) +(gitea/repo-create! ga-forge "alice" "sec" {:visibility "private"}) +(gitea/repo-create! ga-forge "acme" "app" {:visibility "private"}) + +; ── can? basics ────────────────────────────────────────────────────── + +(gitea-access-test + "public read anon" + (gitea/can? ga-forge nil "read" "alice" "pub") + true) +(gitea-access-test + "public read any user" + (gitea/can? ga-forge "eve" "read" "alice" "pub") + true) +(gitea-access-test + "public write anon denied" + (gitea/can? ga-forge nil "write" "alice" "pub") + false) +(gitea-access-test + "public write stranger denied" + (gitea/can? ga-forge "eve" "write" "alice" "pub") + false) +(gitea-access-test + "private read anon denied" + (gitea/can? ga-forge nil "read" "alice" "sec") + false) +(gitea-access-test + "private read stranger denied" + (gitea/can? ga-forge "eve" "read" "alice" "sec") + false) +(gitea-access-test + "owner reads private" + (gitea/can? ga-forge "alice" "read" "alice" "sec") + true) +(gitea-access-test + "owner writes private" + (gitea/can? ga-forge "alice" "write" "alice" "sec") + true) +(gitea-access-test + "owner admins private" + (gitea/can? ga-forge "alice" "admin" "alice" "sec") + true) +(gitea-access-test + "owner admins public" + (gitea/can? ga-forge "alice" "admin" "alice" "pub") + true) +(gitea-access-test + "missing repo denied" + (gitea/can? ga-forge "alice" "read" "alice" "nope") + false) + +; ── collaborators ──────────────────────────────────────────────────── + +(gitea-access-test + "collab-add! bob write" + (get (gitea/collab-add! ga-forge "alice" "sec" "bob" "write") :role) + "write") +(gitea-access-test + "collab-role" + (gitea/collab-role ga-forge "alice" "sec" "bob") + "write") +(gitea-access-test + "collabs list" + (gitea/collabs ga-forge "alice" "sec") + (list "bob")) +(gitea-access-test + "write collab reads" + (gitea/can? ga-forge "bob" "read" "alice" "sec") + true) +(gitea-access-test + "write collab writes" + (gitea/can? ga-forge "bob" "write" "alice" "sec") + true) +(gitea-access-test + "write collab cannot admin" + (gitea/can? ga-forge "bob" "admin" "alice" "sec") + false) + +(gitea/collab-add! ga-forge "alice" "sec" "carol" "read") +(gitea-access-test + "read collab reads" + (gitea/can? ga-forge "carol" "read" "alice" "sec") + true) +(gitea-access-test + "read collab cannot write" + (gitea/can? ga-forge "carol" "write" "alice" "sec") + false) + +(gitea/collab-add! ga-forge "alice" "sec" "carol" "write") +(gitea-access-test + "collab upsert to write" + (gitea/can? ga-forge "carol" "write" "alice" "sec") + true) + +(gitea-access-test + "collab-add! missing repo" + (get (gitea/collab-add! ga-forge "alice" "nope" "bob" "read") :error) + "no-such-repo") +(gitea-access-test + "collab-add! missing user" + (get (gitea/collab-add! ga-forge "alice" "sec" "zeb" "read") :error) + "no-such-user") +(gitea-access-test + "collab-add! bad role" + (get (gitea/collab-add! ga-forge "alice" "sec" "bob" "boss") :error) + "invalid-role") + +(gitea-access-test + "collab-remove! carol" + (gitea/collab-remove! ga-forge "alice" "sec" "carol") + true) +(gitea-access-test + "removed collab cannot write" + (gitea/can? ga-forge "carol" "write" "alice" "sec") + false) +(gitea-access-test + "removed collab cannot read private" + (gitea/can? ga-forge "carol" "read" "alice" "sec") + false) +(gitea-access-test + "collab-remove! again false" + (gitea/collab-remove! ga-forge "alice" "sec" "carol") + false) + +; ── teams ──────────────────────────────────────────────────────────── + +(gitea-access-test + "team-create! owners" + (get (gitea/team-create! ga-forge "acme" "owners" "admin") :role) + "admin") +(gitea-access-test + "team-create! duplicate conflicts" + (get (gitea/team-create! ga-forge "acme" "owners" "read") :conflict) + true) +(gitea-access-test + "team-create! on user rejected" + (get (gitea/team-create! ga-forge "alice" "crew" "read") :error) + "no-such-org") +(gitea-access-test + "team-create! bad role" + (get (gitea/team-create! ga-forge "acme" "crew" "boss") :error) + "invalid-role") + +(gitea/team-add-member! ga-forge "acme" "owners" "alice") +(gitea-access-test + "team-members" + (gitea/team-members ga-forge "acme" "owners") + (list "alice")) +(gitea-access-test + "team-add-member! missing team" + (get (gitea/team-add-member! ga-forge "acme" "ghosts" "bob") :error) + "no-such-team") +(gitea-access-test + "team-add-member! missing user" + (get (gitea/team-add-member! ga-forge "acme" "owners" "zeb") :error) + "no-such-user") + +(gitea-access-test + "owners member admins org repo" + (gitea/can? ga-forge "alice" "admin" "acme" "app") + true) +(gitea-access-test + "owners member reads org repo" + (gitea/can? ga-forge "alice" "read" "acme" "app") + true) +(gitea-access-test + "non-member cannot read org private" + (gitea/can? ga-forge "bob" "read" "acme" "app") + false) +(gitea-access-test + "org-admin? alice" + (gitea/org-admin? ga-forge "acme" "alice") + true) +(gitea-access-test + "org-admin? bob" + (gitea/org-admin? ga-forge "acme" "bob") + false) + +(gitea/team-create! ga-forge "acme" "devs" "write") +(gitea/team-set-repos! ga-forge "acme" "devs" (list "app")) +(gitea/team-add-member! ga-forge "acme" "devs" "bob") + +(gitea-access-test + "devs member writes covered repo" + (gitea/can? ga-forge "bob" "write" "acme" "app") + true) +(gitea-access-test + "devs member cannot admin" + (gitea/can? ga-forge "bob" "admin" "acme" "app") + false) +(gitea-access-test + "org-admin? devs member" + (gitea/org-admin? ga-forge "acme" "bob") + false) + +(gitea/repo-create! ga-forge "acme" "site" {:visibility "private"}) + +(gitea-access-test + "scoped team does not cover new repo" + (gitea/can? ga-forge "bob" "read" "acme" "site") + false) +(gitea-access-test + "all-repos team covers new repo" + (gitea/can? ga-forge "alice" "admin" "acme" "site") + true) + +(gitea/team-set-repos! ga-forge "acme" "devs" "all") +(gitea-access-test + "widened team covers site" + (gitea/can? ga-forge "bob" "write" "acme" "site") + true) +(gitea/team-set-repos! ga-forge "acme" "devs" (list "app")) +(gitea-access-test + "re-narrowed team loses site" + (gitea/can? ga-forge "bob" "write" "acme" "site") + false) + +(gitea/team-remove-member! ga-forge "acme" "devs" "bob") +(gitea-access-test + "removed member loses access" + (gitea/can? ga-forge "bob" "write" "acme" "app") + false) +(gitea/team-add-member! ga-forge "acme" "devs" "bob") + +(gitea-access-test + "team-delete!" + (gitea/team-delete! ga-forge "acme" "devs") + true) +(gitea-access-test + "deleted team gone" + (gitea/teams ga-forge "acme") + (list "owners")) +(gitea-access-test + "deleted team members purged" + (gitea/team-members ga-forge "acme" "devs") + (list)) +(gitea-access-test + "deleted team access revoked" + (gitea/can? ga-forge "bob" "write" "acme" "app") + false) +(gitea-access-test + "team-delete! missing false" + (gitea/team-delete! ga-forge "acme" "devs") + false) + +; ── visibility ─────────────────────────────────────────────────────── + +(gitea-access-test + "visible anon" + (gitea/visible-repos ga-forge nil) + (list "alice/pub")) +(gitea-access-test + "visible eve" + (gitea/visible-repos ga-forge "eve") + (list "alice/pub")) +(gitea-access-test + "visible bob (collab on sec)" + (gitea/visible-repos ga-forge "bob") + (list "alice/pub" "alice/sec")) +(gitea-access-test + "visible alice (owner + org admin)" + (gitea/visible-repos ga-forge "alice") + (list "acme/app" "acme/site" "alice/pub" "alice/sec")) + +; ── create permission ──────────────────────────────────────────────── + +(gitea-access-test + "create under self" + (gitea/create-allowed? ga-forge "alice" "alice") + true) +(gitea-access-test + "create under other user" + (gitea/create-allowed? ga-forge "bob" "alice") + false) +(gitea-access-test + "create anon" + (gitea/create-allowed? ga-forge nil "alice") + false) +(gitea-access-test + "org admin creates in org" + (gitea/create-allowed? ga-forge "alice" "acme") + true) +(gitea-access-test + "non-admin cannot create in org" + (gitea/create-allowed? ga-forge "eve" "acme") + false) +(gitea-access-test + "create under unknown owner" + (gitea/create-allowed? ga-forge "alice" "zeb") + false) + +; ── tokens ─────────────────────────────────────────────────────────── + +(gitea/token-create! ga-forge "alice" "tok-a") +(gitea/token-create! ga-forge "bob" "tok-b") +(gitea/token-create! ga-forge "eve" "tok-e") + +(gitea-access-test + "token resolves user" + (gitea/token-user ga-forge "tok-a") + "alice") +(gitea-access-test "unknown token" (gitea/token-user ga-forge "tok-zzz") nil) +(gitea-access-test + "token for unknown user" + (get (gitea/token-create! ga-forge "zeb" "tok-z") :error) + "no-such-user") +(gitea/token-create! ga-forge "carol" "tok-c") +(gitea/token-revoke! ga-forge "tok-c") +(gitea-access-test "revoked token" (gitea/token-user ga-forge "tok-c") nil) + +; ── auth-gated web routes ──────────────────────────────────────────── + +; content in the private repo, to browse +(define ga-gsec (gitea/repo-git ga-forge "alice" "sec")) +(git/add! ga-gsec "secret.txt" "s3cret\n") +(git/commit! ga-gsec {:message "hide" :time 1 :author "alice"}) + +(define ga-app (gitea/app ga-forge)) +(define ga-hdr (fn (tok) (if (nil? tok) {} {:authorization (str "Bearer " tok)}))) +(define + ga-get + (fn (target tok) (ga-app (dream-request "GET" target (ga-hdr tok) "")))) +(define + ga-post + (fn + (target tok body) + (ga-app (dream-request "POST" target (ga-hdr tok) body)))) +(define + ga-put + (fn + (target tok body) + (ga-app (dream-request "PUT" target (ga-hdr tok) body)))) +(define + ga-del + (fn + (target tok) + (ga-app (dream-request "DELETE" target (ga-hdr tok) "")))) + +(gitea-access-test + "web: public repo anon" + (dream-status (ga-get "/alice/pub" nil)) + 200) +(gitea-access-test + "web: private repo anon hidden" + (dream-status (ga-get "/alice/sec" nil)) + 404) +(gitea-access-test + "web: private repo stranger hidden" + (dream-status (ga-get "/alice/sec" "tok-e")) + 404) +(gitea-access-test + "web: private repo collab" + (dream-status (ga-get "/alice/sec" "tok-b")) + 200) +(gitea-access-test + "web: private repo owner" + (dream-status (ga-get "/alice/sec" "tok-a")) + 200) + +(gitea-access-test + "web: private tree anon hidden" + (dream-status (ga-get "/alice/sec/tree/main" nil)) + 404) +(gitea-access-test + "web: private tree collab" + (dream-status (ga-get "/alice/sec/tree/main" "tok-b")) + 200) +(gitea-access-test + "web: private raw stranger hidden" + (dream-status (ga-get "/alice/sec/raw/main/secret.txt" "tok-e")) + 404) +(gitea-access-test + "web: private raw collab exact" + (dream-resp-body (ga-get "/alice/sec/raw/main/secret.txt" "tok-b")) + "s3cret\n") +(gitea-access-test + "web: private commits owner" + (dream-status (ga-get "/alice/sec/commits/main" "tok-a")) + 200) + +(gitea-access-test + "web: index anon shows public" + (contains? (dream-resp-body (ga-get "/" nil)) "alice/pub") + true) +(gitea-access-test + "web: index anon hides private" + (contains? (dream-resp-body (ga-get "/" nil)) "alice/sec") + false) +(gitea-access-test + "web: index owner shows private" + (contains? (dream-resp-body (ga-get "/" "tok-a")) "alice/sec") + true) + +(gitea-access-test + "web: api repos anon" + (dream-json-parse (dream-resp-body (ga-get "/api/repos" nil))) + (list "alice/pub")) +(gitea-access-test + "web: api repos owner" + (dream-json-parse (dream-resp-body (ga-get "/api/repos" "tok-a"))) + (list "acme/app" "acme/site" "alice/pub" "alice/sec")) + +(gitea-access-test + "web: create anon 401" + (dream-status (ga-post "/api/repos" nil (dream-json-encode {:name "x" :owner "alice"}))) + 401) +(gitea-access-test + "web: create for other user 403" + (dream-status + (ga-post "/api/repos" "tok-b" (dream-json-encode {:name "x" :owner "alice"}))) + 403) +(gitea-access-test + "web: create own 201" + (dream-status + (ga-post "/api/repos" "tok-a" (dream-json-encode {:name "x" :owner "alice"}))) + 201) +(gitea-access-test + "web: org admin create 201" + (dream-status + (ga-post "/api/repos" "tok-a" (dream-json-encode {:name "tools" :owner "acme"}))) + 201) +(gitea-access-test + "web: org non-admin create 403" + (dream-status + (ga-post "/api/repos" "tok-e" (dream-json-encode {:name "z" :owner "acme"}))) + 403) +(gitea-access-test + "web: create unknown owner 400" + (dream-status + (ga-post "/api/repos" "tok-a" (dream-json-encode {:name "z" :owner "zeb"}))) + 400) + +(gitea-access-test + "web: delete anon public 401" + (dream-status (ga-del "/api/repos/alice/x" nil)) + 401) +(gitea-access-test + "web: delete anon private hidden 404" + (dream-status (ga-del "/api/repos/alice/sec" nil)) + 404) +(gitea-access-test + "web: delete stranger private hidden 404" + (dream-status (ga-del "/api/repos/alice/sec" "tok-e")) + 404) +(gitea-access-test + "web: delete non-admin 403" + (dream-status (ga-del "/api/repos/alice/x" "tok-b")) + 403) +(gitea-access-test + "web: delete admin 200" + (dream-status (ga-del "/api/repos/alice/x" "tok-a")) + 200) +(gitea-access-test + "web: deleted repo gone" + (dream-status (ga-del "/api/repos/alice/x" "tok-a")) + 404) + +(gitea-access-test + "web: collab put anon 401" + (dream-status (ga-put "/api/repos/alice/pub/collab/eve" nil "{}")) + 401) +(gitea-access-test + "web: collab put non-admin 403" + (dream-status + (ga-put + "/api/repos/alice/pub/collab/eve" + "tok-b" + (dream-json-encode {:role "write"}))) + 403) +(gitea-access-test + "web: collab put on hidden repo 404" + (dream-status + (ga-put + "/api/repos/alice/sec/collab/eve" + "tok-e" + (dream-json-encode {:role "write"}))) + 404) +(gitea-access-test + "web: collab put admin 200" + (dream-status + (ga-put + "/api/repos/alice/pub/collab/eve" + "tok-a" + (dream-json-encode {:role "write"}))) + 200) +(gitea-access-test + "web: collab granted write" + (gitea/can? ga-forge "eve" "write" "alice" "pub") + true) +(gitea-access-test + "web: collab put bad role 400" + (dream-status + (ga-put + "/api/repos/alice/pub/collab/eve" + "tok-a" + (dream-json-encode {:role "boss"}))) + 400) +(gitea-access-test + "web: collab put unknown user 400" + (dream-status + (ga-put + "/api/repos/alice/pub/collab/zeb" + "tok-a" + (dream-json-encode {:role "read"}))) + 400) +(gitea-access-test + "web: collab delete admin 200" + (dream-status (ga-del "/api/repos/alice/pub/collab/eve" "tok-a")) + 200) +(gitea-access-test + "web: collab revoked" + (gitea/can? ga-forge "eve" "write" "alice" "pub") + false) +(gitea-access-test + "web: collab delete missing 404" + (dream-status (ga-del "/api/repos/alice/pub/collab/eve" "tok-a")) + 404) diff --git a/lib/gitea/tests/activity.sx b/lib/gitea/tests/activity.sx new file mode 100644 index 00000000..9b89386c --- /dev/null +++ b/lib/gitea/tests/activity.sx @@ -0,0 +1,432 @@ +; lib/gitea/tests/activity.sx — Phase 6: instrumented activity log, feed +; timelines with visibility, follows + dashboard, durable notifications +; into per-user inboxes, and the activity web routes. + +(st-bootstrap-classes!) +(content/bootstrap!) +(content-bootstrap-markdown!) +(content-bootstrap-table!) + +(define gitea-act-pass 0) +(define gitea-act-fail 0) +(define gitea-act-fails (list)) + +(define + gitea-act-test + (fn + (name actual expected) + (if + (= actual expected) + (set! gitea-act-pass (+ gitea-act-pass 1)) + (begin + (set! gitea-act-fail (+ gitea-act-fail 1)) + (set! gitea-act-fails (append gitea-act-fails (list {:name name :expected (inspect expected) :actual (inspect actual)}))))))) + +; ── setup + instrumented history ───────────────────────────────────── +; activity ledger (seq/at/actor/verb): +; 1 @5 alice create-repo repo:alice/proj (public) +; 2 @6 alice create-repo repo:alice/sec (private) +; 3 @10 alice open-issue issue:alice/proj#1 +; 4 @11 bob comment issue:alice/proj#1 +; 5 @12 bob open-pr pr:alice/proj#2 +; 6 @13 carol review pr:alice/proj#2 +; 7 @14 alice merge-pr pr:alice/proj#2 +; 8 @20 alice open-issue issue:alice/sec#1 (private) +; 9 @21 alice open-issue issue:alice/proj#3 (assignee bob) + +(define ga-db (persist/mem-backend)) +(define ga-forge (gitea/forge ga-db)) +(gitea/user-create! ga-forge "alice") +(gitea/user-create! ga-forge "bob") +(gitea/user-create! ga-forge "carol") +(gitea/user-create! ga-forge "eve") +(gitea/token-create! ga-forge "alice" "tok-a") +(gitea/token-create! ga-forge "bob" "tok-b") +(gitea/token-create! ga-forge "carol" "tok-c") + +(gitea/repo-create! ga-forge "alice" "proj" {:created-at 5}) +(gitea/repo-create! ga-forge "alice" "sec" {:created-at 6 :visibility "private"}) +(gitea/collab-add! ga-forge "alice" "sec" "bob" "read") + +(define ga-g (gitea/repo-git ga-forge "alice" "proj")) +(git/add! ga-g "README.md" "base\n") +(git/commit! ga-g {:message "c1" :time 1 :author "alice"}) +(git/branch! ga-g "feat") +(git/checkout! ga-g "feat") +(git/add! ga-g "f.txt" "feature\n") +(git/commit! ga-g {:message "c2" :time 2 :author "bob"}) +(git/checkout! ga-g "main") + +(gitea/issue-create! + ga-forge + "alice" + "proj" + "alice" + "First issue" + "body" + {:created-at 10}) +(gitea/issue-comment! + ga-forge + "alice" + "proj" + 1 + "bob" + "a comment" + {:at 11}) +(gitea/pr-create! + ga-forge + "alice" + "proj" + "bob" + "Feature" + "feat" + "main" + "" + {:created-at 12}) +(gitea/pr-review! + ga-forge + "alice" + "proj" + 2 + "carol" + "approve" + "lgtm" + {:at 13}) +(gitea/pr-merge! ga-forge "alice" "proj" 2 "alice" {:time 14}) +(gitea/issue-create! + ga-forge + "alice" + "sec" + "alice" + "Secret issue" + "" + {:created-at 20}) +(gitea/issue-create! + ga-forge + "alice" + "proj" + "alice" + "Assigned issue" + "" + {:assignees (list "bob") :created-at 21}) + +(gitea-act-test "activity count" (gitea/activity-count ga-forge) 9) + +; failed mutations emit nothing +(gitea/issue-create! ga-forge "alice" "none" "alice" "x" "" {}) +(gitea/pr-review! + ga-forge + "alice" + "proj" + 2 + "bob" + "approve" + "" + {}) +(gitea-act-test + "errors emit no activity" + (gitea/activity-count ga-forge) + 9) + +; ── timelines ──────────────────────────────────────────────────────── + +(gitea-act-test + "anon timeline hides private" + (len (gitea/timeline ga-forge nil 50)) + 7) +(gitea-act-test + "owner timeline sees all" + (len (gitea/timeline ga-forge "alice" 50)) + 9) +(gitea-act-test + "timeline newest first" + (get (first (gitea/timeline ga-forge nil 50)) :verb) + "open-issue") +(gitea-act-test + "timeline take" + (len (gitea/timeline ga-forge "alice" 2)) + 2) + +(gitea-act-test + "repo timeline proj" + (len (gitea/repo-timeline ga-forge "alice" "proj" 50)) + 7) +(gitea-act-test + "repo timeline sec" + (len (gitea/repo-timeline ga-forge "alice" "sec" 50)) + 2) +(gitea-act-test + "repo timeline order" + (get (first (gitea/repo-timeline ga-forge "alice" "proj" 50)) :at) + 21) + +(gitea-act-test + "user timeline bob" + (len (gitea/user-timeline ga-forge nil "bob" 50)) + 2) +(gitea-act-test + "user timeline bob order" + (get (first (gitea/user-timeline ga-forge nil "bob" 50)) :verb) + "open-pr") +(gitea-act-test + "user timeline alice anon" + (len (gitea/user-timeline ga-forge nil "alice" 50)) + 4) +(gitea-act-test + "user timeline alice as collab" + (len (gitea/user-timeline ga-forge "bob" "alice" 50)) + 6) + +; ── follows + dashboard ────────────────────────────────────────────── + +(gitea/follow! ga-forge "carol" "user:alice") +(gitea-act-test + "follows list" + (gitea/follows ga-forge "carol") + (list "user:alice")) +(gitea-act-test + "follow unknown follower" + (get (gitea/follow! ga-forge "zeb" "user:alice") :error) + "no-such-user") +(gitea-act-test + "follow unknown user target" + (get (gitea/follow! ga-forge "carol" "user:zeb") :error) + "no-such-target") +(gitea-act-test + "follow unknown repo target" + (get (gitea/follow! ga-forge "carol" "repo:alice/none") :error) + "no-such-target") +(gitea-act-test + "follow malformed target" + (get (gitea/follow! ga-forge "carol" "alice") :error) + "no-such-target") + +(gitea-act-test + "dashboard follows a user" + (len (gitea/dashboard ga-forge "carol" 50)) + 4) +(gitea-act-test + "dashboard first actor" + (get (first (gitea/dashboard ga-forge "carol" 50)) :actor) + "alice") + +(gitea/follow! ga-forge "bob" "repo:alice/proj") +(gitea-act-test + "dashboard follows a repo, excludes own actions" + (len (gitea/dashboard ga-forge "bob" 50)) + 5) + +(gitea-act-test + "unfollow" + (gitea/unfollow! ga-forge "carol" "user:alice") + true) +(gitea-act-test + "dashboard after unfollow" + (len (gitea/dashboard ga-forge "carol" 50)) + 0) +(gitea-act-test + "unfollow twice" + (gitea/unfollow! ga-forge "carol" "user:alice") + false) + +; ── notifications ──────────────────────────────────────────────────── + +(gitea-act-test + "recipients of a comment" + (gitea/notify-recipients + ga-forge + (feed/activity + "bob" + "comment" + "issue:alice/proj#1" + 11 + (list "repo:alice/proj"))) + (list "alice")) +(gitea-act-test + "recipients of a review" + (gitea/notify-recipients + ga-forge + (feed/activity + "carol" + "review" + "pr:alice/proj#2" + 13 + (list "repo:alice/proj"))) + (list "bob")) +(gitea-act-test + "recipients exclude the actor" + (gitea/notify-recipients + ga-forge + (feed/activity + "alice" + "comment" + "issue:alice/proj#1" + 30 + (list "repo:alice/proj"))) + (list "bob")) + +(define ga-pend (gitea/pending-notifications ga-forge)) +(gitea-act-test + "pending message count" + (len (get ga-pend :messages)) + 4) +(gitea-act-test "pending last seq" (get ga-pend :last-seq) 9) + +(define ga-out1 (gitea/notify! ga-forge)) +(gitea-act-test + "notify delivers all" + (len (filter (fn (o) (= (first o) "delivered")) ga-out1)) + 4) +(gitea-act-test "inbox alice" (gitea/inbox-count ga-forge "alice") 1) +(gitea-act-test + "inbox alice body" + (get (first (gitea/inbox ga-forge "alice")) :body) + "bob comment issue:alice/proj#1") +(gitea-act-test "inbox bob" (gitea/inbox-count ga-forge "bob") 3) + +(gitea-act-test "notify rerun is a no-op" (gitea/notify! ga-forge) (list)) +(gitea-act-test + "inboxes stable after rerun" + (gitea/inbox-count ga-forge "bob") + 3) + +; a fresh comment (carol) notifies the author and the other commenter +(gitea/issue-comment! + ga-forge + "alice" + "proj" + 1 + "carol" + "me too" + {:at 30}) +(define ga-out2 (gitea/notify! ga-forge)) +(gitea-act-test "incremental delivery" (len ga-out2) 2) +(gitea-act-test + "inbox alice grows" + (gitea/inbox-count ga-forge "alice") + 2) +(gitea-act-test + "inbox bob grows" + (gitea/inbox-count ga-forge "bob") + 4) + +; ── web ────────────────────────────────────────────────────────────── + +(define ga-app (gitea/app ga-forge)) +(define ga-hdr (fn (tok) (if (nil? tok) {} {:authorization (str "Bearer " tok)}))) +(define + ga-get + (fn (target tok) (ga-app (dream-request "GET" target (ga-hdr tok) "")))) +(define + ga-post + (fn + (target tok body) + (ga-app (dream-request "POST" target (ga-hdr tok) body)))) +(define + ga-del + (fn + (target tok) + (ga-app (dream-request "DELETE" target (ga-hdr tok) "")))) + +(gitea-act-test + "activity page 200" + (dream-status (ga-get "/activity" nil)) + 200) +(gitea-act-test + "activity page shows merges" + (contains? (dream-resp-body (ga-get "/activity" nil)) "merge-pr") + true) +(gitea-act-test + "activity page hides private from anon" + (contains? (dream-resp-body (ga-get "/activity" nil)) "alice/sec") + false) +(gitea-act-test + "activity page shows private to owner" + (contains? (dream-resp-body (ga-get "/activity" "tok-a")) "alice/sec") + true) + +(gitea-act-test + "repo activity page 200" + (dream-status (ga-get "/alice/proj/activity" nil)) + 200) +(gitea-act-test + "repo activity shows pr open" + (contains? (dream-resp-body (ga-get "/alice/proj/activity" nil)) "open-pr") + true) +(gitea-act-test + "private repo activity anon 404" + (dream-status (ga-get "/alice/sec/activity" nil)) + 404) +(gitea-act-test + "private repo activity collab 200" + (dream-status (ga-get "/alice/sec/activity" "tok-b")) + 200) + +(gitea-act-test + "api user activity len" + (len + (dream-json-parse + (dream-resp-body (ga-get "/api/users/bob/activity" nil)))) + 2) +(gitea-act-test + "api user activity unknown 404" + (dream-status (ga-get "/api/users/zeb/activity" nil)) + 404) + +(gitea-act-test + "api dashboard anon 401" + (dream-status (ga-get "/api/dashboard" nil)) + 401) +(gitea-act-test + "api dashboard bob" + (len + (dream-json-parse (dream-resp-body (ga-get "/api/dashboard" "tok-b")))) + 6) + +(gitea-act-test + "api follow anon 401" + (dream-status (ga-post "/api/follow" nil (dream-json-encode {:target "user:bob"}))) + 401) +(gitea-act-test + "api follow 200" + (dream-status + (ga-post "/api/follow" "tok-c" (dream-json-encode {:target "user:bob"}))) + 200) +(gitea-act-test + "api follow recorded" + (gitea/follows ga-forge "carol") + (list "user:bob")) +(gitea-act-test + "api follow bad target 400" + (dream-status + (ga-post "/api/follow" "tok-c" (dream-json-encode {:target "nope"}))) + 400) +(gitea-act-test + "api unfollow 200" + (dream-status (ga-del "/api/follow/user:bob" "tok-c")) + 200) +(gitea-act-test + "api unfollow missing 404" + (dream-status (ga-del "/api/follow/user:bob" "tok-c")) + 404) + +(gitea-act-test + "api notifications anon 401" + (dream-status (ga-get "/api/notifications" nil)) + 401) +(gitea-act-test + "api notifications bodies" + (contains? + (dream-json-parse + (dream-resp-body (ga-get "/api/notifications" "tok-a"))) + "bob comment issue:alice/proj#1") + true) + +(gitea-act-test + "api notify run anon 401" + (dream-status (ga-post "/api/notify/run" nil "{}")) + 401) +(gitea-act-test + "api notify run 200" + (dream-status (ga-post "/api/notify/run" "tok-a" "{}")) + 200) diff --git a/lib/gitea/tests/fed.sx b/lib/gitea/tests/fed.sx new file mode 100644 index 00000000..f92d1023 --- /dev/null +++ b/lib/gitea/tests/fed.sx @@ -0,0 +1,371 @@ +; lib/gitea/tests/fed.sx — Phase 8: ForgeFed. Two in-memory forges: +; AP actor docs + outbox, trust-gated inbox with provenance log and +; materialized federated issues/comments/PRs (proxy users), cursor-based +; outbound delivery, cross-instance repo mirrors, federated timeline. + +(st-bootstrap-classes!) +(content/bootstrap!) +(content-bootstrap-markdown!) +(content-bootstrap-table!) + +(define gitea-fed-pass 0) +(define gitea-fed-fail 0) +(define gitea-fed-fails (list)) + +(define + gitea-fed-test + (fn + (name actual expected) + (if + (= actual expected) + (set! gitea-fed-pass (+ gitea-fed-pass 1)) + (begin + (set! gitea-fed-fail (+ gitea-fed-fail 1)) + (set! gitea-fed-fails (append gitea-fed-fails (list {:name name :expected (inspect expected) :actual (inspect actual)}))))))) + +; ── forge A ────────────────────────────────────────────────────────── + +(define gf-dbA (persist/mem-backend)) +(define gf-A (gitea/forge gf-dbA)) +(gitea/instance! gf-A "forge-a") +(gitea/user-create! gf-A "alice") +(gitea/org-create! gf-A "acme") +(gitea/repo-create! gf-A "alice" "lib" {:created-at 1}) +(gitea/repo-create! gf-A "alice" "hid" {:created-at 2 :visibility "private"}) + +(define gf-gA (gitea/repo-git gf-A "alice" "lib")) +(git/add! gf-gA "README.md" "the lib\n") +(git/commit! gf-gA {:message "c1" :time 3 :author "alice"}) + +(gitea/issue-create! + gf-A + "alice" + "lib" + "alice" + "Public issue" + "hello" + {:created-at 4}) +(gitea/issue-create! + gf-A + "alice" + "hid" + "alice" + "Hidden issue" + "shh" + {:created-at 5}) + +; ── forge B ────────────────────────────────────────────────────────── + +(define gf-dbB (persist/mem-backend)) +(define gf-B (gitea/forge gf-dbB)) +(gitea/instance! gf-B "forge-b") +(gitea/user-create! gf-B "bob") +(gitea/repo-create! gf-B "bob" "hub" {:created-at 10}) + +(define gf-gB (gitea/repo-git gf-B "bob" "hub")) +(git/add! gf-gB "main.txt" "hub main\n") +(git/commit! gf-gB {:message "h1" :time 11 :author "bob"}) +(git/branch! gf-gB "feat") +(git/checkout! gf-gB "feat") +(git/add! gf-gB "feat.txt" "hub feat\n") +(git/commit! gf-gB {:message "h2" :time 12 :author "bob"}) +(git/checkout! gf-gB "main") + +(define gf-appA (gitea/app gf-A)) +(define gf-appB (gitea/app gf-B)) +(gitea/peer-register! gf-B "forge-a" gf-appA nil) +(gitea/peer-register! gf-A "forge-b" gf-appB nil) + +; ── identity + actor documents ─────────────────────────────────────── + +(gitea-fed-test "instance id" (gitea/instance-id gf-A) "forge-a") +(gitea-fed-test + "actor id" + (gitea/actor-id gf-A "user:alice") + "forge-a/user:alice") + +(gitea-fed-test + "ap user type" + (get (gitea/ap-user gf-A "alice") :type) + "Person") +(gitea-fed-test + "ap user id" + (get (gitea/ap-user gf-A "alice") :id) + "forge-a/user:alice") +(gitea-fed-test + "ap org type" + (get (gitea/ap-user gf-A "acme") :type) + "Group") +(gitea-fed-test "ap user missing" (gitea/ap-user gf-A "zeb") nil) + +(gitea-fed-test + "ap repo type" + (get (gitea/ap-repo gf-A "alice" "lib") :type) + "Repository") +(gitea-fed-test + "ap repo attribution" + (get (gitea/ap-repo gf-A "alice" "lib") :attributedTo) + "forge-a/user:alice") +(gitea-fed-test + "ap repo clone endpoint" + (get (gitea/ap-repo gf-A "alice" "lib") :clone) + "/alice/lib/info/refs") + +(gitea-fed-test + "outbox is ap-shaped" + (get (first (gitea/ap-outbox gf-A "alice" 10)) :actor) + "forge-a/user:alice") +(gitea-fed-test + "outbox hides private repos" + (len (gitea/ap-outbox gf-A "alice" 10)) + 2) + +; ── trust ──────────────────────────────────────────────────────────── + +(gitea-fed-test "untrusted by default" (gitea/trusted? gf-B "forge-a") false) +(gitea-fed-test + "inbox rejects untrusted" + (get (gitea/fed-receive! gf-B "forge-a" {:verb "open-issue"}) :error) + "untrusted-peer") +(gitea-fed-test + "rejected activity not logged" + (len (gitea/fed-log gf-B)) + 0) + +(gitea/trust! gf-B "forge-a") +(gitea-fed-test "trusted after trust!" (gitea/trusted? gf-B "forge-a") true) +(gitea-fed-test "trusted peers" (gitea/trusted-peers gf-B) (list "forge-a")) + +; ── inbound materialization ────────────────────────────────────────── + +(define gf-r1 (gitea/fed-receive! gf-B "forge-a" {:actor "forge-a/user:alice" :detail {:title "Fed issue" :body "opened from forge-a"} :object "issue:bob/hub#0" :at 50 :tags (list "repo:bob/hub") :verb "open-issue"})) + +(gitea-fed-test "fed issue accepted" (get gf-r1 :materialized) "issue") +(gitea-fed-test "fed issue number" (get gf-r1 :number) 1) +(gitea-fed-test + "proxy user created" + (gitea/owner-exists? gf-B "alice@forge-a") + true) +(gitea-fed-test + "fed issue author" + (get (gitea/issue-get gf-B "bob" "hub" 1) :author) + "alice@forge-a") +(gitea-fed-test + "fed issue title" + (get (gitea/issue-get gf-B "bob" "hub" 1) :title) + "Fed issue") +(gitea-fed-test + "fed log provenance" + (get (first (gitea/fed-log gf-B)) :origin) + "forge-a") + +(define gf-owners-before (len (gitea/owners gf-B))) +(define gf-r2 (gitea/fed-receive! gf-B "forge-a" {:actor "forge-a/user:alice" :detail {:body "following up"} :object "issue:bob/hub#1" :at 51 :tags (list "repo:bob/hub") :verb "comment"})) + +(gitea-fed-test "fed comment accepted" (get gf-r2 :materialized) "comment") +(gitea-fed-test + "fed comment recorded" + (len (get (gitea/issue-get gf-B "bob" "hub" 1) :comments)) + 1) +(gitea-fed-test + "proxy user reused" + (len (gitea/owners gf-B)) + gf-owners-before) + +(define gf-r3 (gitea/fed-receive! gf-B "forge-a" {:actor "forge-a/user:alice" :detail {:source "feat" :title "Fed PR" :body "take my branch" :target "main"} :object "pr:bob/hub#0" :at 52 :tags (list "repo:bob/hub") :verb "open-pr"})) + +(gitea-fed-test "fed pr accepted" (get gf-r3 :materialized) "pr") +(gitea-fed-test + "fed pr author" + (get (gitea/pr-get gf-B "bob" "hub" (get gf-r3 :number)) :author) + "alice@forge-a") +(gitea-fed-test + "fed pr branches" + (get (gitea/pr-get gf-B "bob" "hub" (get gf-r3 :number)) :source) + "feat") + +(gitea-fed-test + "unknown verb still logged" + (get (gitea/fed-receive! gf-B "forge-a" {:actor "forge-a/user:alice" :object "repo:bob/hub" :at 53 :tags (list "repo:bob/hub") :verb "star"}) :materialized) + "none") +(gitea-fed-test + "comment with bad object" + (get (gitea/fed-receive! gf-B "forge-a" {:actor "forge-a/user:alice" :object "nonsense" :at 54 :verb "comment"}) :error) + "bad-object") +(gitea-fed-test "fed log grows" (len (gitea/fed-log gf-B)) 5) + +; ── inbox over the wire ────────────────────────────────────────────── + +(define + gf-postB + (fn + (body) + (gf-appB (dream-request "POST" "/api/ap/inbox" {} body)))) + +(gitea-fed-test + "web inbox missing peer 400" + (dream-status (gf-postB (dream-json-encode {:activity {}}))) + 400) +(gitea-fed-test + "web inbox untrusted 403" + (dream-status (gf-postB (dream-json-encode {:activity {} :peer "forge-x"}))) + 403) +(gitea-fed-test + "web inbox trusted 200" + (dream-status (gf-postB (dream-json-encode {:activity {:actor "forge-a/user:alice" :detail {:body "via web"} :object "issue:bob/hub#1" :at 55 :tags (list "repo:bob/hub") :verb "comment"} :peer "forge-a"}))) + 200) +(gitea-fed-test + "web inbox materialized" + (len (get (gitea/issue-get gf-B "bob" "hub" 1) :comments)) + 2) + +; ── mirrors (cross-instance repo follow) ───────────────────────────── + +(define gf-m1 (gitea/mirror! gf-B "bob" "libmirror" "forge-a" "alice" "lib")) +(gitea-fed-test "mirror clones" (get gf-m1 :owner) "bob") +(gitea-fed-test + "mirror branch matches upstream" + (git/branch-get (gitea/repo-git gf-B "bob" "libmirror") "main") + (git/branch-get gf-gA "main")) +(gitea-fed-test + "mirror recorded" + (get (gitea/mirror-of gf-B "bob" "libmirror") :peer) + "forge-a") +(gitea-fed-test "mirrors list" (gitea/mirrors gf-B) (list "bob/libmirror")) + +(git/checkout! gf-gA "main") +(git/add! gf-gA "more.txt" "more\n") +(define gf-c2 (git/commit! gf-gA {:message "c2" :time 6 :author "alice"})) + +(gitea-fed-test + "mirror-sync pulls new commits" + (get (gitea/mirror-sync! gf-B "bob" "libmirror") :stored) + 3) +(gitea-fed-test + "mirror advanced" + (git/branch-get (gitea/repo-git gf-B "bob" "libmirror") "main") + gf-c2) + +(gitea/untrust! gf-B "forge-a") +(gitea-fed-test + "sync of untrusted peer refused" + (get (gitea/mirror-sync! gf-B "bob" "libmirror") :error) + "untrusted-peer") +(gitea-fed-test + "mirror of untrusted peer refused" + (get (gitea/mirror! gf-B "bob" "another" "forge-a" "alice" "lib") :error) + "untrusted-peer") +(gitea/trust! gf-B "forge-a") +(gitea-fed-test + "sync ok after re-trust" + (get (gitea/mirror-sync! gf-B "bob" "libmirror") :stored) + 0) +(gitea-fed-test + "non-mirror sync refused" + (get (gitea/mirror-sync! gf-B "bob" "hub") :error) + "not-a-mirror") + +; ── outbound delivery ──────────────────────────────────────────────── + +(gitea/trust! gf-A "forge-b") +(define gf-d1 (gitea/fed-deliver! gf-A)) + +; A's public activity so far: create-repo lib, open-issue lib#1, +; comment... none; private create/issue excluded +(gitea-fed-test + "deliver pushes public only" + (get gf-d1 :delivered) + 2) +(gitea-fed-test + "deliver reaches trusted peers" + (get gf-d1 :peers) + (list "forge-b")) +(gitea-fed-test + "peer logged deliveries" + (len (gitea/fed-log gf-B)) + 8) +(gitea-fed-test + "delivered origin" + (get + (first + (filter + (fn (e) (= (get (get e :activity) :verb) "create-repo")) + (gitea/fed-log gf-B))) + :origin) + "forge-a") + +(gitea-fed-test + "second deliver is a no-op" + (get (gitea/fed-deliver! gf-A) :delivered) + 0) + +(gitea/issue-comment! + gf-A + "alice" + "lib" + 1 + "alice" + "one more" + {:at 7}) +(gitea-fed-test + "incremental deliver" + (get (gitea/fed-deliver! gf-A) :delivered) + 1) + +; ── federated timeline ─────────────────────────────────────────────── + +(define gf-tl (gitea/fed-timeline gf-B nil 100)) +(gitea-fed-test + "fed timeline mixes local and foreign" + (> + (len (filter (fn (a) (= (get a :origin) "forge-a")) gf-tl)) + 0) + true) +(gitea-fed-test + "local activities carry no origin" + (> + (len + (filter + (fn + (a) + (and (nil? (get a :origin)) (= (get a :verb) "create-repo"))) + gf-tl)) + 0) + true) + +; ── actor docs over the wire ───────────────────────────────────────── + +(define + gf-getA + (fn (target) (gf-appA (dream-request "GET" target {} "")))) + +(gitea-fed-test + "web ap user 200" + (dream-status (gf-getA "/api/ap/users/alice")) + 200) +(gitea-fed-test + "web ap user type" + (get + (dream-json-parse (dream-resp-body (gf-getA "/api/ap/users/alice"))) + :type) + "Person") +(gitea-fed-test + "web ap user missing 404" + (dream-status (gf-getA "/api/ap/users/zeb")) + 404) +(gitea-fed-test + "web ap repo 200" + (dream-status (gf-getA "/api/ap/repos/alice/lib")) + 200) +(gitea-fed-test + "web ap private repo hidden" + (dream-status (gf-getA "/api/ap/repos/alice/hid")) + 404) +(gitea-fed-test + "web outbox 200" + (dream-status (gf-getA "/api/ap/users/alice/outbox")) + 200) +(gitea-fed-test + "web fed timeline 200" + (dream-status (gf-getA "/api/fed/timeline")) + 200) diff --git a/lib/gitea/tests/issues.sx b/lib/gitea/tests/issues.sx new file mode 100644 index 00000000..5fa8236c --- /dev/null +++ b/lib/gitea/tests/issues.sx @@ -0,0 +1,571 @@ +; lib/gitea/tests/issues.sx — Phase 4: issue CRUD, comments, labels, +; assignees, content-document bodies (Markdown round-trip + HTML render), +; the derived relations graph, repo-delete purge regression, and the +; issue web routes + JSON API. + +(st-bootstrap-classes!) +(content/bootstrap!) +(content-bootstrap-markdown!) +(content-bootstrap-table!) + +(define gitea-issues-pass 0) +(define gitea-issues-fail 0) +(define gitea-issues-fails (list)) + +(define + gitea-issues-test + (fn + (name actual expected) + (if + (= actual expected) + (set! gitea-issues-pass (+ gitea-issues-pass 1)) + (begin + (set! gitea-issues-fail (+ gitea-issues-fail 1)) + (set! + gitea-issues-fails + (append gitea-issues-fails (list {:name name :expected (inspect expected) :actual (inspect actual)}))))))) + +; ── helpers ────────────────────────────────────────────────────────── + +(gitea-issues-test "pad8" (gitea/pad8 7) "00000007") +(gitea-issues-test "pad8 wide" (gitea/pad8 12345) "00012345") +(gitea-issues-test "digits? yes" (gitea/digits? "123") true) +(gitea-issues-test "digits? no" (gitea/digits? "12a") false) +(gitea-issues-test "digits? empty" (gitea/digits? "") false) + +; ── setup ──────────────────────────────────────────────────────────── + +(define gi-db (persist/mem-backend)) +(define gi-forge (gitea/forge gi-db)) +(gitea/user-create! gi-forge "alice") +(gitea/user-create! gi-forge "bob") +(gitea/user-create! gi-forge "carol") +(gitea/user-create! gi-forge "eve") +(gitea/repo-create! gi-forge "alice" "proj" {}) +(gitea/repo-create! gi-forge "alice" "sec" {:visibility "private"}) +(gitea/collab-add! gi-forge "alice" "sec" "bob" "read") +(gitea/token-create! gi-forge "alice" "tok-a") +(gitea/token-create! gi-forge "bob" "tok-b") +(gitea/token-create! gi-forge "eve" "tok-e") + +; ── issue CRUD ─────────────────────────────────────────────────────── + +(define + gi-i1 + (gitea/issue-create! + gi-forge + "alice" + "proj" + "alice" + "Crash on boot" + "It crashes." + {:created-at 10})) + +(gitea-issues-test "create number" (get gi-i1 :number) 1) +(gitea-issues-test "create state" (get gi-i1 :state) "open") +(gitea-issues-test "create title" (get gi-i1 :title) "Crash on boot") +(gitea-issues-test "create author" (get gi-i1 :author) "alice") +(gitea-issues-test "create created-at" (get gi-i1 :created-at) 10) + +(define + gi-i2 + (gitea/issue-create! + gi-forge + "alice" + "proj" + "bob" + "Add docs" + "Docs please." + {})) +(gitea-issues-test "second number" (get gi-i2 :number) 2) + +(gitea-issues-test + "issue-get" + (get (gitea/issue-get gi-forge "alice" "proj" 1) :title) + "Crash on boot") +(gitea-issues-test + "issues list" + (gitea/issues gi-forge "alice" "proj") + (list 1 2)) +(gitea-issues-test + "issue-records len" + (len (gitea/issue-records gi-forge "alice" "proj")) + 2) + +(gitea-issues-test + "create on missing repo" + (get + (gitea/issue-create! gi-forge "alice" "none" "alice" "t" "" {}) + :error) + "no-such-repo") +(gitea-issues-test + "create by missing user" + (get + (gitea/issue-create! gi-forge "alice" "proj" "zeb" "t" "" {}) + :error) + "no-such-user") +(gitea-issues-test + "create empty title" + (get + (gitea/issue-create! gi-forge "alice" "proj" "alice" "" "" {}) + :error) + "empty-title") + +(gitea/issue-close! gi-forge "alice" "proj" 2) +(gitea-issues-test + "close!" + (get (gitea/issue-get gi-forge "alice" "proj" 2) :state) + "closed") +(gitea/issue-reopen! gi-forge "alice" "proj" 2) +(gitea-issues-test + "reopen!" + (get (gitea/issue-get gi-forge "alice" "proj" 2) :state) + "open") +(gitea-issues-test + "close missing" + (gitea/issue-close! gi-forge "alice" "proj" 99) + nil) +(gitea/issue-close! gi-forge "alice" "proj" 2) + +; ── comments ───────────────────────────────────────────────────────── + +(gitea-issues-test + "comment author" + (get + (gitea/issue-comment! + gi-forge + "alice" + "proj" + 1 + "bob" + "Repro *here*." + {:at 11}) + :author) + "bob") +(gitea/issue-comment! + gi-forge + "alice" + "proj" + 1 + "carol" + "Same for me." + {:at 12}) + +(gitea-issues-test + "comments appended" + (len (get (gitea/issue-get gi-forge "alice" "proj" 1) :comments)) + 2) +(gitea-issues-test + "comment order" + (get + (first + (get (gitea/issue-get gi-forge "alice" "proj" 1) :comments)) + :body) + "Repro *here*.") +(gitea-issues-test + "comment on missing issue" + (get + (gitea/issue-comment! + gi-forge + "alice" + "proj" + 99 + "bob" + "x" + {}) + :error) + "no-such-issue") +(gitea-issues-test + "comment by missing user" + (get + (gitea/issue-comment! + gi-forge + "alice" + "proj" + 1 + "zeb" + "x" + {}) + :error) + "no-such-user") + +; ── labels / assignees ─────────────────────────────────────────────── + +(gitea/issue-label! gi-forge "alice" "proj" 1 "ui") +(gitea/issue-label! gi-forge "alice" "proj" 1 "bug") +(gitea-issues-test + "labels sorted" + (get (gitea/issue-get gi-forge "alice" "proj" 1) :labels) + (list "bug" "ui")) +(gitea/issue-label! gi-forge "alice" "proj" 1 "bug") +(gitea-issues-test + "label idempotent" + (get (gitea/issue-get gi-forge "alice" "proj" 1) :labels) + (list "bug" "ui")) +(gitea/issue-unlabel! gi-forge "alice" "proj" 1 "bug") +(gitea-issues-test + "unlabel" + (get (gitea/issue-get gi-forge "alice" "proj" 1) :labels) + (list "ui")) +(gitea-issues-test + "invalid label" + (get (gitea/issue-label! gi-forge "alice" "proj" 1 "") :error) + "invalid-label") + +(gitea/issue-assign! gi-forge "alice" "proj" 2 "carol") +(gitea-issues-test + "assign" + (get (gitea/issue-get gi-forge "alice" "proj" 2) :assignees) + (list "carol")) +(gitea-issues-test + "assign unknown user" + (get (gitea/issue-assign! gi-forge "alice" "proj" 2 "zeb") :error) + "no-such-user") + +; ── views ──────────────────────────────────────────────────────────── + +(gitea-issues-test + "issues-open" + (len (gitea/issues-open gi-forge "alice" "proj")) + 1) +(gitea-issues-test + "issues-closed" + (len (gitea/issues-closed gi-forge "alice" "proj")) + 1) +(gitea-issues-test + "issues-with-label" + (map + (fn (r) (get r :number)) + (gitea/issues-with-label gi-forge "alice" "proj" "ui")) + (list 1)) +(gitea-issues-test + "issues-assigned" + (map + (fn (r) (get r :number)) + (gitea/issues-assigned gi-forge "alice" "proj" "carol")) + (list 2)) + +; ── content documents ──────────────────────────────────────────────── + +(define gi-md "# Heading\n\npara text.\n\n```sx\n(+ 1 2)\n```") +(define + gi-i3 + (gitea/issue-create! + gi-forge + "alice" + "proj" + "alice" + "With md body" + gi-md + {})) +(define gi-doc (gitea/issue-doc "alice" "proj" gi-i3)) + +(gitea-issues-test "issue doc block count" (content/count gi-doc) 3) +(gitea-issues-test + "issue doc types" + (content/types gi-doc) + (list "heading" "text" "code")) +(gitea-issues-test + "issue html heading" + (contains? (gitea/issue-html "alice" "proj" gi-i3) "

    Heading

    ") + true) +(gitea-issues-test + "issue html code block" + (contains? (gitea/issue-html "alice" "proj" gi-i3) "
    ")
    +  true)
    +
    +; ── relations graph ──────────────────────────────────────────────────
    +
    +(gitea-issues-test
    +  "repo issue nodes"
    +  (gitea/repo-issue-nodes gi-forge "alice" "proj")
    +  (list "issue:alice/proj#1" "issue:alice/proj#2" "issue:alice/proj#3"))
    +(gitea-issues-test
    +  "authored by alice"
    +  (gitea/user-authored gi-forge "alice")
    +  (list "issue:alice/proj#1" "issue:alice/proj#3"))
    +(gitea-issues-test
    +  "authored by bob"
    +  (gitea/user-authored gi-forge "bob")
    +  (list "issue:alice/proj#2"))
    +(gitea-issues-test
    +  "assigned to carol"
    +  (gitea/user-assigned gi-forge "carol")
    +  (list "issue:alice/proj#2"))
    +(gitea-issues-test
    +  "label issues"
    +  (gitea/label-issues gi-forge "alice" "proj" "ui")
    +  (list "issue:alice/proj#1"))
    +(gitea-issues-test
    +  "participants incl commenters"
    +  (gitea/issue-participants gi-forge "alice" "proj" 1)
    +  (list "user:alice" "user:bob" "user:carol"))
    +(gitea-issues-test
    +  "participants author+assignee"
    +  (gitea/issue-participants gi-forge "alice" "proj" 2)
    +  (list "user:bob" "user:carol"))
    +
    +; ── repo delete purges issue state ───────────────────────────────────
    +
    +(gitea/repo-create! gi-forge "alice" "tmp" {})
    +(gitea/issue-create! gi-forge "alice" "tmp" "alice" "Ghost?" "" {})
    +(gitea/collab-add! gi-forge "alice" "tmp" "carol" "write")
    +(gitea/repo-delete! gi-forge "alice" "tmp")
    +(gitea/repo-create! gi-forge "alice" "tmp" {})
    +
    +(gitea-issues-test
    +  "recreated repo has no ghost issues"
    +  (gitea/issues gi-forge "alice" "tmp")
    +  (list))
    +(gitea-issues-test
    +  "recreated repo has no ghost collabs"
    +  (gitea/collabs gi-forge "alice" "tmp")
    +  (list))
    +(gitea-issues-test
    +  "issue numbering restarts"
    +  (get
    +    (gitea/issue-create! gi-forge "alice" "tmp" "alice" "Fresh" "" {})
    +    :number)
    +  1)
    +(gitea/repo-delete! gi-forge "alice" "tmp")
    +(gitea-issues-test
    +  "deleted repo leaves no issue edges"
    +  (gitea/repo-issue-nodes gi-forge "alice" "tmp")
    +  (list))
    +
    +; ── web routes ───────────────────────────────────────────────────────
    +
    +(define gi-app (gitea/app gi-forge))
    +(define gi-hdr (fn (tok) (if (nil? tok) {} {:authorization (str "Bearer " tok)})))
    +(define
    +  gi-get
    +  (fn (target tok) (gi-app (dream-request "GET" target (gi-hdr tok) ""))))
    +(define
    +  gi-post
    +  (fn
    +    (target tok body)
    +    (gi-app (dream-request "POST" target (gi-hdr tok) body))))
    +(define
    +  gi-put
    +  (fn
    +    (target tok body)
    +    (gi-app (dream-request "PUT" target (gi-hdr tok) body))))
    +(define
    +  gi-del
    +  (fn
    +    (target tok)
    +    (gi-app (dream-request "DELETE" target (gi-hdr tok) ""))))
    +
    +(gitea-issues-test
    +  "issues page 200"
    +  (dream-status (gi-get "/alice/proj/issues" nil))
    +  200)
    +(gitea-issues-test
    +  "issues page lists title"
    +  (contains?
    +    (dream-resp-body (gi-get "/alice/proj/issues" nil))
    +    "Crash on boot")
    +  true)
    +(gitea-issues-test
    +  "issues page shows state"
    +  (contains? (dream-resp-body (gi-get "/alice/proj/issues" nil)) "[closed]")
    +  true)
    +
    +(gitea-issues-test
    +  "issue page 200"
    +  (dream-status (gi-get "/alice/proj/issues/1" nil))
    +  200)
    +(gitea-issues-test
    +  "issue page shows author"
    +  (contains? (dream-resp-body (gi-get "/alice/proj/issues/1" nil)) "alice")
    +  true)
    +(gitea-issues-test
    +  "issue page renders body html"
    +  (contains?
    +    (dream-resp-body (gi-get "/alice/proj/issues/3" nil))
    +    "

    Heading

    ") + true) +(gitea-issues-test + "issue page renders comments" + (contains? + (dream-resp-body (gi-get "/alice/proj/issues/1" nil)) + "Same for me.") + true) +(gitea-issues-test + "issue page bad number 404" + (dream-status (gi-get "/alice/proj/issues/abc" nil)) + 404) +(gitea-issues-test + "issue page missing 404" + (dream-status (gi-get "/alice/proj/issues/99" nil)) + 404) +(gitea-issues-test + "private issues anon 404" + (dream-status (gi-get "/alice/sec/issues" nil)) + 404) +(gitea-issues-test + "private issues collab 200" + (dream-status (gi-get "/alice/sec/issues" "tok-b")) + 200) + +(gitea-issues-test + "api issues len" + (len + (dream-json-parse + (dream-resp-body (gi-get "/api/repos/alice/proj/issues" nil)))) + 3) +(gitea-issues-test + "api issues first number" + (get + (first + (dream-json-parse + (dream-resp-body (gi-get "/api/repos/alice/proj/issues" nil)))) + :number) + 1) + +(gitea-issues-test + "api create anon 401" + (dream-status + (gi-post + "/api/repos/alice/proj/issues" + nil + (dream-json-encode {:title "t"}))) + 401) +(gitea-issues-test + "api create reader 201" + (dream-status + (gi-post + "/api/repos/alice/proj/issues" + "tok-e" + (dream-json-encode {:title "From eve" :body "hi"}))) + 201) +(gitea-issues-test + "api created number" + (len (gitea/issues gi-forge "alice" "proj")) + 4) +(gitea-issues-test + "api create on private hidden 404" + (dream-status + (gi-post + "/api/repos/alice/sec/issues" + "tok-e" + (dream-json-encode {:title "x"}))) + 404) +(gitea-issues-test + "api create empty title 400" + (dream-status + (gi-post + "/api/repos/alice/proj/issues" + "tok-e" + (dream-json-encode {:title ""}))) + 400) + +(gitea-issues-test + "api comment 200" + (dream-status + (gi-post + "/api/repos/alice/proj/issues/4/comments" + "tok-b" + (dream-json-encode {:body "noted"}))) + 200) +(gitea-issues-test + "api comment recorded" + (len (get (gitea/issue-get gi-forge "alice" "proj" 4) :comments)) + 1) +(gitea-issues-test + "api comment anon 401" + (dream-status + (gi-post + "/api/repos/alice/proj/issues/4/comments" + nil + (dream-json-encode {:body "x"}))) + 401) +(gitea-issues-test + "api comment missing issue 404" + (dream-status + (gi-post + "/api/repos/alice/proj/issues/99/comments" + "tok-b" + (dream-json-encode {:body "x"}))) + 404) + +; eve authored #4 and may close it without write; reopen as alice (write) +(gitea-issues-test + "api close by author 200" + (dream-status (gi-post "/api/repos/alice/proj/issues/4/close" "tok-e" "{}")) + 200) +(gitea-issues-test + "api close applied" + (get (gitea/issue-get gi-forge "alice" "proj" 4) :state) + "closed") +(gitea-issues-test + "api reopen by write 200" + (dream-status + (gi-post "/api/repos/alice/proj/issues/4/reopen" "tok-a" "{}")) + 200) + +; issue #5: authored by alice — eve (reader, not author) may not close +(gitea/issue-create! + gi-forge + "alice" + "proj" + "alice" + "Owner issue" + "" + {}) +(gitea-issues-test + "api close by stranger 403" + (dream-status (gi-post "/api/repos/alice/proj/issues/5/close" "tok-e" "{}")) + 403) + +(gitea-issues-test + "api label put by write 200" + (dream-status + (gi-put "/api/repos/alice/proj/issues/5/labels/bug" "tok-a" "{}")) + 200) +(gitea-issues-test + "api label applied" + (get (gitea/issue-get gi-forge "alice" "proj" 5) :labels) + (list "bug")) +(gitea-issues-test + "api label by reader 403" + (dream-status + (gi-put "/api/repos/alice/proj/issues/5/labels/x" "tok-e" "{}")) + 403) +(gitea-issues-test + "api label delete 200" + (dream-status (gi-del "/api/repos/alice/proj/issues/5/labels/bug" "tok-a")) + 200) +(gitea-issues-test + "api label removed" + (get (gitea/issue-get gi-forge "alice" "proj" 5) :labels) + (list)) + +(gitea-issues-test + "api assign 200" + (dream-status + (gi-put "/api/repos/alice/proj/issues/5/assignees/bob" "tok-a" "{}")) + 200) +(gitea-issues-test + "api assign applied" + (get (gitea/issue-get gi-forge "alice" "proj" 5) :assignees) + (list "bob")) +(gitea-issues-test + "api assign unknown user 400" + (dream-status + (gi-put "/api/repos/alice/proj/issues/5/assignees/zeb" "tok-a" "{}")) + 400) +(gitea-issues-test + "api unassign 200" + (dream-status + (gi-del "/api/repos/alice/proj/issues/5/assignees/bob" "tok-a")) + 200) +(gitea-issues-test + "api unassign applied" + (get (gitea/issue-get gi-forge "alice" "proj" 5) :assignees) + (list)) diff --git a/lib/gitea/tests/pr.sx b/lib/gitea/tests/pr.sx new file mode 100644 index 00000000..a0981f34 --- /dev/null +++ b/lib/gitea/tests/pr.sx @@ -0,0 +1,865 @@ +; lib/gitea/tests/pr.sx — Phase 5: PR records, live merge-base diffs, +; review threads (latest verdict per reviewer), the durable flow +; lifecycle, all four merge shapes (merge/ff/up-to-date/conflicts), the +; merge queue, and the PR web routes + JSON API. + +(st-bootstrap-classes!) +(content/bootstrap!) +(content-bootstrap-markdown!) +(content-bootstrap-table!) + +(define gitea-pr-pass 0) +(define gitea-pr-fail 0) +(define gitea-pr-fails (list)) + +(define + gitea-pr-test + (fn + (name actual expected) + (if + (= actual expected) + (set! gitea-pr-pass (+ gitea-pr-pass 1)) + (begin + (set! gitea-pr-fail (+ gitea-pr-fail 1)) + (set! gitea-pr-fails (append gitea-pr-fails (list {:name name :expected (inspect expected) :actual (inspect actual)}))))))) + +; ── setup: repo with diverged branches ─────────────────────────────── + +(define gp-db (persist/mem-backend)) +(define gp-forge (gitea/forge gp-db)) +(gitea/user-create! gp-forge "alice") +(gitea/user-create! gp-forge "bob") +(gitea/user-create! gp-forge "carol") +(gitea/user-create! gp-forge "eve") +(gitea/repo-create! gp-forge "alice" "proj" {}) +(gitea/repo-create! gp-forge "alice" "sec" {:visibility "private"}) +(gitea/token-create! gp-forge "alice" "tok-a") +(gitea/token-create! gp-forge "bob" "tok-b") +(gitea/token-create! gp-forge "carol" "tok-c") +(gitea/token-create! gp-forge "eve" "tok-e") + +(define gp-g (gitea/repo-git gp-forge "alice" "proj")) +(git/add! gp-g "README.md" "base\n") +(git/add! gp-g "lib.txt" "lib\n") +(define gp-c1 (git/commit! gp-g {:message "c1" :time 1 :author "alice"})) +(git/branch! gp-g "feat") +(git/checkout! gp-g "feat") +(git/add! gp-g "feature.txt" "feature line\n") +(define gp-c2 (git/commit! gp-g {:message "c2 feature" :time 2 :author "bob"})) +(git/checkout! gp-g "main") +(git/add! gp-g "other.txt" "other\n") +(define gp-c3 (git/commit! gp-g {:message "c3 other" :time 3 :author "alice"})) + +; ── create / validate ──────────────────────────────────────────────── + +(define + gp-pr1 + (gitea/pr-create! + gp-forge + "alice" + "proj" + "bob" + "Add feature" + "feat" + "main" + "Adds a *feature*." + {:created-at 5})) + +(gitea-pr-test "pr number" (get gp-pr1 :number) 1) +(gitea-pr-test "pr state" (get gp-pr1 :state) "open") +(gitea-pr-test "pr source" (get gp-pr1 :source) "feat") +(gitea-pr-test "pr target" (get gp-pr1 :target) "main") +(gitea-pr-test "pr has flow id" (nil? (get gp-pr1 :flow-id)) false) +(gitea-pr-test + "flow starts at review" + (gitea/pr-flow-status gp-forge gp-pr1) + "review") + +(gitea-pr-test + "unknown source" + (get + (gitea/pr-create! + gp-forge + "alice" + "proj" + "bob" + "t" + "nope" + "main" + "" + {}) + :error) + "no-such-source") +(gitea-pr-test + "unknown target" + (get + (gitea/pr-create! + gp-forge + "alice" + "proj" + "bob" + "t" + "feat" + "nope" + "" + {}) + :error) + "no-such-target") +(gitea-pr-test + "same branch" + (get + (gitea/pr-create! + gp-forge + "alice" + "proj" + "bob" + "t" + "main" + "main" + "" + {}) + :error) + "same-branch") +(gitea-pr-test + "empty title" + (get + (gitea/pr-create! + gp-forge + "alice" + "proj" + "bob" + "" + "feat" + "main" + "" + {}) + :error) + "empty-title") +(gitea-pr-test + "missing repo" + (get + (gitea/pr-create! + gp-forge + "alice" + "none" + "bob" + "t" + "feat" + "main" + "" + {}) + :error) + "no-such-repo") +(gitea-pr-test + "missing author" + (get + (gitea/pr-create! + gp-forge + "alice" + "proj" + "zeb" + "t" + "feat" + "main" + "" + {}) + :error) + "no-such-user") + +(gitea-pr-test + "prs list" + (gitea/prs gp-forge "alice" "proj") + (list 1)) + +; numbers are shared with issues +(gitea-pr-test + "shared counter with issues" + (get + (gitea/issue-create! + gp-forge + "alice" + "proj" + "alice" + "An issue" + "" + {}) + :number) + 2) + +; ── live diff against the merge base ───────────────────────────────── + +(gitea-pr-test + "diff added" + (get (gitea/pr-diff gp-forge "alice" "proj" 1) :added) + (list "feature.txt")) +(gitea-pr-test + "diff no spurious deletions" + (get (gitea/pr-diff gp-forge "alice" "proj" 1) :deleted) + (list)) +(gitea-pr-test + "diff unified shows addition" + (contains? + (gitea/pr-diff-unified gp-forge "alice" "proj" 1) + "+feature line") + true) +(gitea-pr-test + "diff of missing pr" + (gitea/pr-diff gp-forge "alice" "proj" 99) + nil) + +; ── reviews ────────────────────────────────────────────────────────── + +(gitea/pr-review! + gp-forge + "alice" + "proj" + 1 + "carol" + "request-changes" + "needs tests" + {:at 6}) +(gitea-pr-test + "changes requested blocks approval" + (gitea/pr-approved? (gitea/pr-get gp-forge "alice" "proj" 1)) + false) +(gitea-pr-test + "flow still at review" + (gitea/pr-flow-status + gp-forge + (gitea/pr-get gp-forge "alice" "proj" 1)) + "review") + +(gitea-pr-test + "author cannot review own pr" + (get + (gitea/pr-review! + gp-forge + "alice" + "proj" + 1 + "bob" + "approve" + "" + {}) + :error) + "own-pr") +(gitea-pr-test + "invalid verdict" + (get + (gitea/pr-review! + gp-forge + "alice" + "proj" + 1 + "carol" + "meh" + "" + {}) + :error) + "invalid-verdict") +(gitea-pr-test + "unknown reviewer" + (get + (gitea/pr-review! + gp-forge + "alice" + "proj" + 1 + "zeb" + "approve" + "" + {}) + :error) + "no-such-user") +(gitea-pr-test + "review missing pr" + (get + (gitea/pr-review! + gp-forge + "alice" + "proj" + 99 + "carol" + "approve" + "" + {}) + :error) + "no-such-pr") + +(gitea/pr-review! + gp-forge + "alice" + "proj" + 1 + "carol" + "approve" + "looks good now" + {:at 7}) +(gitea-pr-test + "latest verdict wins" + (gitea/pr-approved? (gitea/pr-get gp-forge "alice" "proj" 1)) + true) +(gitea-pr-test + "reviews accumulate" + (len (get (gitea/pr-get gp-forge "alice" "proj" 1) :reviews)) + 2) +(gitea-pr-test + "flow advanced to approved" + (gitea/pr-flow-status + gp-forge + (gitea/pr-get gp-forge "alice" "proj" 1)) + "approved") + +; ── merge: true 3-way ──────────────────────────────────────────────── + +(gitea-pr-test + "unapproved merge rejected" + (get + (gitea/pr-merge! gp-forge "alice" "proj" 2 "alice" {}) + :error) + "no-such-pr") + +(define + gp-m1 + (gitea/pr-merge! gp-forge "alice" "proj" 1 "alice" {:time 8})) + +(gitea-pr-test "merge state" (get gp-m1 :state) "merged") +(gitea-pr-test "merge cid recorded" (nil? (get gp-m1 :merge-cid)) false) +(gitea-pr-test + "main moved to merge commit" + (git/branch-get gp-g "main") + (get gp-m1 :merge-cid)) +(gitea-pr-test + "merge commit has two parents" + (git/commit-parents (git/read gp-g (get gp-m1 :merge-cid))) + (list gp-c3 gp-c2)) +(gitea-pr-test + "merged tree keeps target file" + (get (gitea/tree-at gp-g (get gp-m1 :merge-cid) "other.txt") :kind) + "blob") +(gitea-pr-test + "merged tree gains source file" + (get (gitea/tree-at gp-g (get gp-m1 :merge-cid) "feature.txt") :kind) + "blob") +(gitea-pr-test + "flow reports merged" + (gitea/pr-flow-status + gp-forge + (gitea/pr-get gp-forge "alice" "proj" 1)) + "merged") +(gitea-pr-test + "merge twice rejected" + (get + (gitea/pr-merge! gp-forge "alice" "proj" 1 "alice" {}) + :error) + "not-open") +(gitea-pr-test + "review after merge rejected" + (get + (gitea/pr-review! + gp-forge + "alice" + "proj" + 1 + "carol" + "approve" + "" + {}) + :error) + "not-open") + +; ── merge: fast-forward ────────────────────────────────────────────── + +(git/checkout! gp-g "main") +(git/branch! gp-g "hot") +(git/checkout! gp-g "hot") +(git/add! gp-g "hotfix.txt" "fix\n") +(define gp-c4 (git/commit! gp-g {:message "hotfix" :time 9 :author "bob"})) +(git/checkout! gp-g "main") + +(define + gp-pr3 + (gitea/pr-create! + gp-forge + "alice" + "proj" + "bob" + "Hotfix" + "hot" + "main" + "" + {})) +(gitea-pr-test "pr3 number" (get gp-pr3 :number) 3) +(gitea/pr-review! + gp-forge + "alice" + "proj" + 3 + "carol" + "approve" + "" + {}) +(define + gp-m3 + (gitea/pr-merge! gp-forge "alice" "proj" 3 "alice" {})) +(gitea-pr-test "ff merge state" (get gp-m3 :state) "merged") +(gitea-pr-test + "ff moves main to source head" + (git/branch-get gp-g "main") + gp-c4) +(gitea-pr-test "ff merge-cid is source head" (get gp-m3 :merge-cid) gp-c4) + +; ── merge: up-to-date ──────────────────────────────────────────────── + +(git/checkout! gp-g "main") +(git/branch! gp-g "same") +(define + gp-pr4 + (gitea/pr-create! + gp-forge + "alice" + "proj" + "bob" + "No-op" + "same" + "main" + "" + {})) +(gitea/pr-review! + gp-forge + "alice" + "proj" + 4 + "carol" + "approve" + "" + {}) +(define + gp-m4 + (gitea/pr-merge! gp-forge "alice" "proj" 4 "alice" {})) +(gitea-pr-test "up-to-date merge state" (get gp-m4 :state) "merged") +(gitea-pr-test "up-to-date leaves main" (git/branch-get gp-g "main") gp-c4) + +; ── merge: conflicts ───────────────────────────────────────────────── + +(git/checkout! gp-g "main") +(git/branch! gp-g "conf") +(git/checkout! gp-g "conf") +(git/add! gp-g "lib.txt" "conf version\n") +(git/commit! gp-g {:message "conf change" :time 10 :author "bob"}) +(git/checkout! gp-g "main") +(git/add! gp-g "lib.txt" "main version\n") +(git/commit! gp-g {:message "main change" :time 11 :author "alice"}) + +(define + gp-pr5 + (gitea/pr-create! + gp-forge + "alice" + "proj" + "bob" + "Conflicting" + "conf" + "main" + "" + {})) +(gitea/pr-review! + gp-forge + "alice" + "proj" + 5 + "carol" + "approve" + "" + {}) +(define + gp-m5 + (gitea/pr-merge! gp-forge "alice" "proj" 5 "alice" {})) +(gitea-pr-test "conflict merge errors" (get gp-m5 :error) "conflicts") +(gitea-pr-test "conflict paths" (get gp-m5 :conflicts) (list "lib.txt")) +(gitea-pr-test + "conflict leaves pr open" + (get (gitea/pr-get gp-forge "alice" "proj" 5) :state) + "open") +(gitea-pr-test + "conflict leaves flow at approved" + (gitea/pr-flow-status + gp-forge + (gitea/pr-get gp-forge "alice" "proj" 5)) + "approved") + +; ── close / reopen ─────────────────────────────────────────────────── + +(gitea/pr-close! gp-forge "alice" "proj" 5) +(gitea-pr-test + "close state" + (get (gitea/pr-get gp-forge "alice" "proj" 5) :state) + "closed") +(gitea-pr-test + "close cancels flow" + (gitea/pr-flow-status + gp-forge + (gitea/pr-get gp-forge "alice" "proj" 5)) + "closed") +(gitea-pr-test + "merge closed pr rejected" + (get + (gitea/pr-merge! gp-forge "alice" "proj" 5 "alice" {}) + :error) + "not-open") +(gitea-pr-test + "close twice" + (gitea/pr-close! gp-forge "alice" "proj" 5) + nil) + +(gitea/pr-reopen! gp-forge "alice" "proj" 5) +(gitea-pr-test + "reopen state" + (get (gitea/pr-get gp-forge "alice" "proj" 5) :state) + "open") +(gitea-pr-test + "reopen restarts lifecycle" + (gitea/pr-flow-status + gp-forge + (gitea/pr-get gp-forge "alice" "proj" 5)) + "review") + +; ── merge queue ────────────────────────────────────────────────────── + +(git/checkout! gp-g "main") +(git/branch! gp-g "q1") +(git/checkout! gp-g "q1") +(git/add! gp-g "q1.txt" "one\n") +(git/commit! gp-g {:message "q1" :time 12 :author "bob"}) +(git/checkout! gp-g "main") +(git/branch! gp-g "q2") +(git/checkout! gp-g "q2") +(git/add! gp-g "q2.txt" "two\n") +(git/commit! gp-g {:message "q2" :time 13 :author "bob"}) +(git/checkout! gp-g "main") +(git/branch! gp-g "q3") +(git/checkout! gp-g "q3") +(git/add! gp-g "q3.txt" "three\n") +(git/commit! gp-g {:message "q3" :time 14 :author "bob"}) +(git/checkout! gp-g "main") + +(define + gp-pr6 + (gitea/pr-create! + gp-forge + "alice" + "proj" + "bob" + "Queue one" + "q1" + "main" + "" + {})) +(define + gp-pr7 + (gitea/pr-create! + gp-forge + "alice" + "proj" + "bob" + "Queue two" + "q2" + "main" + "" + {})) +(define + gp-pr8 + (gitea/pr-create! + gp-forge + "alice" + "proj" + "bob" + "Queue three" + "q3" + "main" + "" + {})) +(gitea/pr-review! + gp-forge + "alice" + "proj" + 6 + "carol" + "approve" + "" + {}) +(gitea/pr-review! + gp-forge + "alice" + "proj" + 7 + "carol" + "approve" + "" + {}) +; pr8 stays unapproved; pr5 (reopened, approved, conflicting) joins the queue + +(gitea-pr-test + "queue starts empty" + (gitea/queue gp-forge "alice" "proj") + (list)) +(gitea-pr-test + "queue rejects unapproved" + (get (gitea/queue-add! gp-forge "alice" "proj" 8) :error) + "not-approved") +(gitea-pr-test + "queue rejects missing" + (get (gitea/queue-add! gp-forge "alice" "proj" 99) :error) + "no-such-pr") + +(gitea/queue-add! gp-forge "alice" "proj" 6) +(gitea/queue-add! gp-forge "alice" "proj" 6) +(gitea/queue-add! gp-forge "alice" "proj" 7) +(gitea/queue-add! gp-forge "alice" "proj" 5) +(gitea-pr-test + "queue dedups" + (gitea/queue gp-forge "alice" "proj") + (list 6 7 5)) + +(define gp-qres (gitea/queue-process! gp-forge "alice" "proj" "alice")) +(gitea-pr-test "queue processed all" (len gp-qres) 3) +(gitea-pr-test + "queue pr6 merged" + (get (nth gp-qres 0) :merged) + true) +(gitea-pr-test + "queue pr7 merged" + (get (nth gp-qres 1) :merged) + true) +(gitea-pr-test + "queue pr5 conflicts" + (get (nth gp-qres 2) :error) + "conflicts") +(gitea-pr-test + "failures stay queued" + (gitea/queue gp-forge "alice" "proj") + (list 5)) +(gitea-pr-test + "pr6 state merged" + (get (gitea/pr-get gp-forge "alice" "proj" 6) :state) + "merged") +(gitea-pr-test + "pr7 state merged" + (get (gitea/pr-get gp-forge "alice" "proj" 7) :state) + "merged") +(gitea-pr-test + "main has both queue files" + (get (gitea/tree-at gp-g (git/branch-get gp-g "main") "q2.txt") :kind) + "blob") + +(gitea/queue-remove! gp-forge "alice" "proj" 5) +(gitea-pr-test "queue-remove!" (gitea/queue gp-forge "alice" "proj") (list)) + +; ── web routes ─────────────────────────────────────────────────────── + +(define gp-app (gitea/app gp-forge)) +(define gp-hdr (fn (tok) (if (nil? tok) {} {:authorization (str "Bearer " tok)}))) +(define + gp-get + (fn (target tok) (gp-app (dream-request "GET" target (gp-hdr tok) "")))) +(define + gp-post + (fn + (target tok body) + (gp-app (dream-request "POST" target (gp-hdr tok) body)))) + +(gitea-pr-test + "pulls page 200" + (dream-status (gp-get "/alice/proj/pulls" nil)) + 200) +(gitea-pr-test + "pulls page shows title" + (contains? + (dream-resp-body (gp-get "/alice/proj/pulls" nil)) + "Add feature") + true) +(gitea-pr-test + "pulls page shows state" + (contains? (dream-resp-body (gp-get "/alice/proj/pulls" nil)) "[merged]") + true) + +(gitea-pr-test + "pull page 200" + (dream-status (gp-get "/alice/proj/pulls/1" nil)) + 200) +(gitea-pr-test + "pull page shows branches" + (contains? + (dream-resp-body (gp-get "/alice/proj/pulls/1" nil)) + "feat -> main") + true) +(gitea-pr-test + "pull page renders body" + (contains? (dream-resp-body (gp-get "/alice/proj/pulls/1" nil)) "

    ") + true) +(gitea-pr-test + "pull page shows review verdict" + (contains? + (dream-resp-body (gp-get "/alice/proj/pulls/1" nil)) + "carol: approve") + true) +(gitea-pr-test + "pull page shows lifecycle" + (contains? (dream-resp-body (gp-get "/alice/proj/pulls/1" nil)) "merged") + true) +(gitea-pr-test + "pull page bad number 404" + (dream-status (gp-get "/alice/proj/pulls/abc" nil)) + 404) +(gitea-pr-test + "pull page missing 404" + (dream-status (gp-get "/alice/proj/pulls/99" nil)) + 404) +(gitea-pr-test + "private pulls anon 404" + (dream-status (gp-get "/alice/sec/pulls" nil)) + 404) + +(gitea-pr-test + "api pulls len" + (len + (dream-json-parse + (dream-resp-body (gp-get "/api/repos/alice/proj/pulls" nil)))) + 7) +(gitea-pr-test + "api pulls first source" + (get + (first + (dream-json-parse + (dream-resp-body (gp-get "/api/repos/alice/proj/pulls" nil)))) + :source) + "feat") + +(gitea-pr-test + "api create anon 401" + (dream-status + (gp-post "/api/repos/alice/proj/pulls" nil (dream-json-encode {:source "q3" :title "t" :target "main"}))) + 401) +(gitea-pr-test + "api create 201" + (dream-status + (gp-post + "/api/repos/alice/proj/pulls" + "tok-e" + (dream-json-encode {:source "q3" :title "Eve PR" :body "please" :target "main"}))) + 201) +(gitea-pr-test + "api create bad source 400" + (dream-status + (gp-post + "/api/repos/alice/proj/pulls" + "tok-e" + (dream-json-encode {:source "zz" :title "t" :target "main"}))) + 400) + +; eve's PR is #9 +(gitea-pr-test + "api review 200" + (dream-status + (gp-post + "/api/repos/alice/proj/pulls/9/reviews" + "tok-c" + (dream-json-encode {:verdict "approve" :body "ok"}))) + 200) +(gitea-pr-test + "api self-review 400" + (dream-status + (gp-post + "/api/repos/alice/proj/pulls/9/reviews" + "tok-e" + (dream-json-encode {:verdict "approve"}))) + 400) +(gitea-pr-test + "api review anon 401" + (dream-status + (gp-post + "/api/repos/alice/proj/pulls/9/reviews" + nil + (dream-json-encode {:verdict "approve"}))) + 401) +(gitea-pr-test + "api review missing pr 404" + (dream-status + (gp-post + "/api/repos/alice/proj/pulls/99/reviews" + "tok-c" + (dream-json-encode {:verdict "approve"}))) + 404) + +(gitea-pr-test + "api merge reader 403" + (dream-status (gp-post "/api/repos/alice/proj/pulls/9/merge" "tok-e" "{}")) + 403) +(gitea-pr-test + "api merge anon 401" + (dream-status (gp-post "/api/repos/alice/proj/pulls/9/merge" nil "{}")) + 401) +(gitea-pr-test + "api merge write 200" + (dream-status (gp-post "/api/repos/alice/proj/pulls/9/merge" "tok-a" "{}")) + 200) +(gitea-pr-test + "api merge applied" + (get (gitea/pr-get gp-forge "alice" "proj" 9) :state) + "merged") + +; reopened conflicting pr 5 still conflicts over the api +(gitea-pr-test + "api merge conflict 409" + (dream-status (gp-post "/api/repos/alice/proj/pulls/5/merge" "tok-a" "{}")) + 409) + +; eve authors #10 and may close it herself; carol (reader) may not +(gp-post "/api/repos/alice/proj/pulls" "tok-e" (dream-json-encode {:source "conf" :title "To close" :target "main"})) +(gitea-pr-test + "api close by reader 403" + (dream-status (gp-post "/api/repos/alice/proj/pulls/10/close" "tok-c" "{}")) + 403) +(gitea-pr-test + "api close by author 200" + (dream-status (gp-post "/api/repos/alice/proj/pulls/10/close" "tok-e" "{}")) + 200) +(gitea-pr-test + "api close applied" + (get (gitea/pr-get gp-forge "alice" "proj" 10) :state) + "closed") +(gitea-pr-test + "api close again 409" + (dream-status (gp-post "/api/repos/alice/proj/pulls/10/close" "tok-e" "{}")) + 409) + +; queue over the api: pr5 is approved (reviews survive reopen) +(gitea-pr-test + "api enqueue reader 403" + (dream-status + (gp-post "/api/repos/alice/proj/pulls/5/enqueue" "tok-e" "{}")) + 403) +(gitea-pr-test + "api enqueue 200" + (dream-status + (gp-post "/api/repos/alice/proj/pulls/5/enqueue" "tok-a" "{}")) + 200) +(gitea-pr-test + "api queue json" + (dream-json-parse + (dream-resp-body (gp-get "/api/repos/alice/proj/merge-queue" nil))) + (list 5)) +(gitea-pr-test + "api queue process 200" + (dream-status + (gp-post "/api/repos/alice/proj/merge-queue/process" "tok-a" "{}")) + 200) +(gitea-pr-test + "api queue process reports conflict" + (get + (first + (dream-json-parse + (dream-resp-body + (gp-post "/api/repos/alice/proj/merge-queue/process" "tok-a" "{}")))) + :error) + "conflicts") diff --git a/lib/gitea/tests/repo.sx b/lib/gitea/tests/repo.sx new file mode 100644 index 00000000..58cbe9bc --- /dev/null +++ b/lib/gitea/tests/repo.sx @@ -0,0 +1,454 @@ +; lib/gitea/tests/repo.sx — Phase 1: forge core (owners, repo CRUD, git +; wiring, ref/tree navigation) and the dream browse views + JSON API. +; Mutating API calls authenticate as alice (Phase 2 gates them). + +(define gitea-repo-pass 0) +(define gitea-repo-fail 0) +(define gitea-repo-fails (list)) + +; compare with = (structural), not equal? — map/filter-derived lists fail +; equal? against literals even when they print identically +(define + gitea-repo-test + (fn + (name actual expected) + (if + (= actual expected) + (set! gitea-repo-pass (+ gitea-repo-pass 1)) + (begin + (set! gitea-repo-fail (+ gitea-repo-fail 1)) + (set! gitea-repo-fails (append gitea-repo-fails (list {:name name :expected (inspect expected) :actual (inspect actual)}))))))) + +(define gt-db (persist/mem-backend)) +(define gt-forge (gitea/forge gt-db)) + +; ── owners ─────────────────────────────────────────────────────────── + +(gitea-repo-test + "user-create returns user record" + (get (gitea/user-create! gt-forge "alice") :kind) + "user") +(gitea-repo-test + "org-create returns org record" + (get (gitea/org-create! gt-forge "acme") :kind) + "org") +(gitea-repo-test + "owner-get finds alice" + (get (gitea/owner-get gt-forge "alice") :name) + "alice") +(gitea-repo-test "owner-exists?" (gitea/owner-exists? gt-forge "alice") true) +(gitea-repo-test + "user? on user" + (gitea/user? (gitea/owner-get gt-forge "alice")) + true) +(gitea-repo-test + "org? on org" + (gitea/org? (gitea/owner-get gt-forge "acme")) + true) +(gitea-repo-test + "user? on org" + (gitea/user? (gitea/owner-get gt-forge "acme")) + false) +(gitea-repo-test + "duplicate owner conflicts" + (get (gitea/user-create! gt-forge "alice") :conflict) + true) +(gitea-repo-test + "owner name with slash rejected" + (get (gitea/user-create! gt-forge "a/b") :error) + "invalid-name") +(gitea-repo-test + "owner name empty rejected" + (get (gitea/user-create! gt-forge "") :error) + "invalid-name") +(gitea-repo-test + "reserved owner name rejected" + (get (gitea/user-create! gt-forge "api") :error) + "invalid-name") +(gitea-repo-test + "owners sorted" + (gitea/owners gt-forge) + (list "acme" "alice")) + +; ── repo CRUD ──────────────────────────────────────────────────────── + +(define gt-rec (gitea/repo-create! gt-forge "alice" "proj" {:description "demo" :created-at 42})) + +(gitea-repo-test "repo-create owner" (get gt-rec :owner) "alice") +(gitea-repo-test "repo-create name" (get gt-rec :name) "proj") +(gitea-repo-test + "repo-create default visibility" + (get gt-rec :visibility) + "public") +(gitea-repo-test + "repo-create default branch" + (get gt-rec :default-branch) + "main") +(gitea-repo-test + "repo-create keeps created-at" + (get gt-rec :created-at) + 42) +(gitea-repo-test + "repo-get description" + (get (gitea/repo-get gt-forge "alice" "proj") :description) + "demo") +(gitea-repo-test + "repo-exists?" + (gitea/repo-exists? gt-forge "alice" "proj") + true) +(gitea-repo-test + "repo-get missing" + (gitea/repo-get gt-forge "alice" "nope") + nil) +(gitea-repo-test + "repo-create unknown owner" + (get (gitea/repo-create! gt-forge "bob" "x" {}) :error) + "no-such-owner") +(gitea-repo-test + "repo-create duplicate conflicts" + (get (gitea/repo-create! gt-forge "alice" "proj" {}) :conflict) + true) +(gitea-repo-test + "repo-create bad name" + (get (gitea/repo-create! gt-forge "alice" "ba d" {}) :error) + "invalid-name") +(gitea-repo-test + "repos lists alice/proj" + (gitea/repos gt-forge) + (list "alice/proj")) + +(gitea/repo-create! gt-forge "acme" "proj" {}) + +(gitea-repo-test + "same name under two owners" + (gitea/repos gt-forge) + (list "acme/proj" "alice/proj")) +(gitea-repo-test + "repos-for alice" + (gitea/repos-for gt-forge "alice") + (list "proj")) +(gitea-repo-test + "repo-update! description" + (begin + (gitea/repo-update! + gt-forge + "alice" + "proj" + (fn (r) (assoc r :description "rewritten"))) + (get (gitea/repo-get gt-forge "alice" "proj") :description)) + "rewritten") +(gitea-repo-test + "repo-update! missing repo" + (gitea/repo-update! gt-forge "alice" "nope" (fn (r) r)) + nil) + +(gitea/repo-create! gt-forge "alice" "hidden" {:visibility "private"}) +(gitea-repo-test + "private visibility stored" + (get (gitea/repo-get gt-forge "alice" "hidden") :visibility) + "private") + +; ── git store wiring ───────────────────────────────────────────────── + +(define gt-grepo (gitea/repo-git gt-forge "alice" "proj")) + +(gitea-repo-test "new repo HEAD unborn" (git/head gt-grepo) nil) +(gitea-repo-test + "new repo HEAD targets main" + (git/head-target gt-grepo) + "heads/main") +(gitea-repo-test "new repo has no branches" (git/branches gt-grepo) (list)) + +(git/add! gt-grepo "README.md" "hello forge") +(git/add! gt-grepo "src/a.txt" "alpha\n") +(git/add! gt-grepo "src/b.txt" "beta\n") +(define gt-c1 (git/commit! gt-grepo {:message "init" :time 1 :author "alice"})) + +(gitea-repo-test + "commit! advances main" + (git/branch-get gt-grepo "main") + gt-c1) + +(git/add! gt-grepo "src/a.txt" "alpha2\n") +(define gt-c2 (git/commit! gt-grepo {:message "tweak a" :time 2 :author "alice"})) + +(gitea-repo-test + "log newest first" + (git/log gt-grepo gt-c2) + (list gt-c2 gt-c1)) +(gitea-repo-test "branches lists main" (git/branches gt-grepo) (list "main")) + +(define gt-grepo2 (gitea/repo-git gt-forge "acme" "proj")) + +(gitea-repo-test + "objects invisible across repos" + (git/has? gt-grepo2 gt-c1) + false) + +; ── ref resolution ─────────────────────────────────────────────────── + +(gitea-repo-test "resolve branch" (gitea/resolve-ref gt-grepo "main") gt-c2) + +(git/tag-lightweight! gt-grepo "v1") +(gitea-repo-test + "resolve lightweight tag" + (gitea/resolve-ref gt-grepo "v1") + gt-c2) + +(git/tag! gt-grepo "v2" {:message "release" :time 3}) +(gitea-repo-test + "resolve annotated tag peels to commit" + (gitea/resolve-ref gt-grepo "v2") + gt-c2) + +(gitea-repo-test "resolve raw cid" (gitea/resolve-ref gt-grepo gt-c1) gt-c1) +(gitea-repo-test + "resolve unknown ref" + (gitea/resolve-ref gt-grepo "nope") + nil) + +; ── tree navigation ────────────────────────────────────────────────── + +(gitea-repo-test + "tree-at root is tree" + (get (gitea/tree-at gt-grepo gt-c2 "") :kind) + "tree") +(gitea-repo-test + "tree-at file is blob" + (get (gitea/tree-at gt-grepo gt-c2 "src/a.txt") :kind) + "blob") +(gitea-repo-test + "tree-at file cid matches content" + (get (gitea/tree-at gt-grepo gt-c2 "src/a.txt") :cid) + (git/cid (git/blob "alpha2\n"))) +(gitea-repo-test + "tree-at dir is tree" + (get (gitea/tree-at gt-grepo gt-c2 "src") :kind) + "tree") +(gitea-repo-test + "tree-at missing path" + (gitea/tree-at gt-grepo gt-c2 "src/zzz") + nil) +(gitea-repo-test + "tree-at path through blob" + (gitea/tree-at gt-grepo gt-c2 "README.md/x") + nil) +(gitea-repo-test + "tree-at non-commit cid" + (gitea/tree-at gt-grepo (git/cid (git/blob "alpha2\n")) "") + nil) + +; ── browse views ───────────────────────────────────────────────────── + +(define gt-app (gitea/app gt-forge)) +(define + gt-get + (fn (target) (gt-app (dream-request "GET" target {} "")))) + +(gitea/token-create! gt-forge "alice" "tok-alice") +(define gt-auth {:authorization "Bearer tok-alice"}) +(define + gt-posta + (fn (target body) (gt-app (dream-request "POST" target gt-auth body)))) +(define + gt-dela + (fn (target) (gt-app (dream-request "DELETE" target gt-auth "")))) + +(gitea-repo-test "GET / status" (dream-status (gt-get "/")) 200) +(gitea-repo-test + "GET / lists repos" + (contains? (dream-resp-body (gt-get "/")) "alice/proj") + true) + +(gitea-repo-test + "repo home status" + (dream-status (gt-get "/alice/proj")) + 200) +(gitea-repo-test + "repo home shows description" + (contains? (dream-resp-body (gt-get "/alice/proj")) "rewritten") + true) +(gitea-repo-test + "repo home shows branch" + (contains? (dream-resp-body (gt-get "/alice/proj")) "main") + true) +(gitea-repo-test + "empty repo home" + (contains? (dream-resp-body (gt-get "/acme/proj")) "empty repository") + true) +(gitea-repo-test + "unknown repo 404" + (dream-status (gt-get "/nobody/none")) + 404) + +(gitea-repo-test + "branches page lists main" + (contains? (dream-resp-body (gt-get "/alice/proj/branches")) "main") + true) +(gitea-repo-test + "branches page unknown repo 404" + (dream-status (gt-get "/nobody/none/branches")) + 404) + +(gitea-repo-test + "tree root status" + (dream-status (gt-get "/alice/proj/tree/main")) + 200) +(gitea-repo-test + "tree root lists src" + (contains? (dream-resp-body (gt-get "/alice/proj/tree/main")) "src") + true) +(gitea-repo-test + "tree root lists README" + (contains? (dream-resp-body (gt-get "/alice/proj/tree/main")) "README.md") + true) +(gitea-repo-test + "tree subdir lists a.txt" + (contains? (dream-resp-body (gt-get "/alice/proj/tree/main/src")) "a.txt") + true) +(gitea-repo-test + "tree at tag" + (dream-status (gt-get "/alice/proj/tree/v1")) + 200) +(gitea-repo-test + "tree bad ref 404" + (dream-status (gt-get "/alice/proj/tree/nope")) + 404) +(gitea-repo-test + "tree on blob path 404" + (dream-status (gt-get "/alice/proj/tree/main/README.md")) + 404) + +(gitea-repo-test + "blob status" + (dream-status (gt-get "/alice/proj/blob/main/src/a.txt")) + 200) +(gitea-repo-test + "blob shows content" + (contains? + (dream-resp-body (gt-get "/alice/proj/blob/main/src/a.txt")) + "alpha2") + true) +(gitea-repo-test + "blob on tree path 404" + (dream-status (gt-get "/alice/proj/blob/main/src")) + 404) +(gitea-repo-test + "raw body exact" + (dream-resp-body (gt-get "/alice/proj/raw/main/src/a.txt")) + "alpha2\n") +(gitea-repo-test + "raw missing file 404" + (dream-status (gt-get "/alice/proj/raw/main/zzz")) + 404) + +(gitea-repo-test + "commits status" + (dream-status (gt-get "/alice/proj/commits/main")) + 200) +(gitea-repo-test + "commits show newest message" + (contains? (dream-resp-body (gt-get "/alice/proj/commits/main")) "tweak a") + true) +(gitea-repo-test + "commits show oldest message" + (contains? (dream-resp-body (gt-get "/alice/proj/commits/main")) "init") + true) +(gitea-repo-test + "commits bad ref 404" + (dream-status (gt-get "/alice/proj/commits/nope")) + 404) + +(gitea-repo-test + "commit view message" + (contains? + (dream-resp-body (gt-get (str "/alice/proj/commit/" gt-c2))) + "tweak a") + true) +(gitea-repo-test + "commit view diff content" + (contains? + (dream-resp-body (gt-get (str "/alice/proj/commit/" gt-c2))) + "alpha2") + true) +(gitea-repo-test + "root commit lists files" + (contains? + (dream-resp-body (gt-get (str "/alice/proj/commit/" gt-c1))) + "README.md") + true) +(gitea-repo-test + "commit bad cid 404" + (dream-status (gt-get "/alice/proj/commit/zzz")) + 404) + +; ── json api (as alice) ────────────────────────────────────────────── + +(gitea-repo-test + "api repos json (anon: public only)" + (dream-json-parse (dream-resp-body (gt-get "/api/repos"))) + (list "acme/proj" "alice/proj")) + +(gitea-repo-test + "api create 201" + (dream-status (gt-posta "/api/repos" (dream-json-encode {:name "web" :owner "alice"}))) + 201) +(gitea-repo-test + "api create persisted" + (gitea/repo-exists? gt-forge "alice" "web") + true) +(gitea-repo-test + "api create duplicate 409" + (dream-status (gt-posta "/api/repos" (dream-json-encode {:name "web" :owner "alice"}))) + 409) +(gitea-repo-test + "api create unknown owner 400" + (dream-status (gt-posta "/api/repos" (dream-json-encode {:name "web" :owner "zeb"}))) + 400) +(gitea-repo-test + "api create bad name 400" + (dream-status (gt-posta "/api/repos" (dream-json-encode {:name "b d" :owner "alice"}))) + 400) +(gitea-repo-test + "api delete 200" + (dream-status (gt-dela "/api/repos/alice/web")) + 200) +(gitea-repo-test + "api delete gone" + (gitea/repo-exists? gt-forge "alice" "web") + false) +(gitea-repo-test + "api delete missing 404" + (dream-status (gt-dela "/api/repos/alice/web")) + 404) + +; ── delete purges the git namespace ────────────────────────────────── + +(gitea/repo-create! gt-forge "alice" "tmp" {}) +(define gt-gtmp (gitea/repo-git gt-forge "alice" "tmp")) +(git/add! gt-gtmp "f.txt" "data") +(git/commit! gt-gtmp {:message "x" :time 9}) + +(gitea-repo-test + "delete returns true" + (gitea/repo-delete! gt-forge "alice" "tmp") + true) +(gitea-repo-test + "delete removes record" + (gitea/repo-get gt-forge "alice" "tmp") + nil) +(gitea-repo-test + "delete purges git keys" + (len + (filter + (fn (k) (starts-with? k "forge/alice/tmp/")) + (persist/kv-keys gt-db))) + 0) +(gitea-repo-test + "delete missing returns false" + (gitea/repo-delete! gt-forge "alice" "tmp") + false) +(gitea-repo-test + "other repos survive delete" + (gitea/repos gt-forge) + (list "acme/proj" "alice/hidden" "alice/proj")) diff --git a/lib/gitea/tests/search.sx b/lib/gitea/tests/search.sx new file mode 100644 index 00000000..0d1bca61 --- /dev/null +++ b/lib/gitea/tests/search.sx @@ -0,0 +1,266 @@ +; lib/gitea/tests/search.sx — Phase 7: code + issue/PR search over +; search-on-sx. All SX-level queries run as ONE haskell evaluation +; (gitea/search-multi over five corpora); the web tests add one +; evaluation per request. + +(st-bootstrap-classes!) +(content/bootstrap!) +(content-bootstrap-markdown!) +(content-bootstrap-table!) + +(define gitea-search-pass 0) +(define gitea-search-fail 0) +(define gitea-search-fails (list)) + +(define + gitea-search-test + (fn + (name actual expected) + (if + (= actual expected) + (set! gitea-search-pass (+ gitea-search-pass 1)) + (begin + (set! gitea-search-fail (+ gitea-search-fail 1)) + (set! + gitea-search-fails + (append gitea-search-fails (list {:name name :expected (inspect expected) :actual (inspect actual)}))))))) + +; ── escaping ───────────────────────────────────────────────────────── + +(gitea-search-test "hk-escape quotes" (gitea/hk-escape "a\"b") "a\\\"b") +(gitea-search-test "hk-escape newline" (gitea/hk-escape "a\nb") "a\\nb") +(gitea-search-test "hk-escape backslash" (gitea/hk-escape "a\\b") "a\\\\b") +(gitea-search-test "hk-escape nil" (gitea/hk-escape nil) "") + +; ── setup ──────────────────────────────────────────────────────────── + +(define gs-db (persist/mem-backend)) +(define gs-forge (gitea/forge gs-db)) +(gitea/user-create! gs-forge "alice") +(gitea/user-create! gs-forge "bob") +(gitea/token-create! gs-forge "alice" "tok-a") +(gitea/repo-create! gs-forge "alice" "proj" {}) +(gitea/repo-create! gs-forge "alice" "sec" {:visibility "private"}) +(gitea/repo-create! gs-forge "alice" "empty" {}) + +(define gs-g (gitea/repo-git gs-forge "alice" "proj")) +(git/add! gs-g "README.md" "SX forge documentation overview") +(git/add! gs-g "src/main.sx" "(define forge-main entry) banana runtime") +(git/add! gs-g "docs/guide.md" "how to search the forge") +(git/commit! gs-g {:message "c1" :time 1 :author "alice"}) +(git/branch! gs-g "feat") +(git/checkout! gs-g "feat") +(git/add! gs-g "src/extra.sx" "cherry helpers") +(git/commit! gs-g {:message "c2" :time 2 :author "alice"}) +(git/checkout! gs-g "main") + +(define gs-gs (gitea/repo-git gs-forge "alice" "sec")) +(git/add! gs-gs "secret.txt" "banana secret stash") +(git/commit! gs-gs {:message "s1" :time 3 :author "alice"}) + +(gitea/issue-create! + gs-forge + "alice" + "proj" + "alice" + "Crash in search" + "the search crashes on banana input" + {:created-at 10}) +(gitea/issue-comment! + gs-forge + "alice" + "proj" + 1 + "bob" + "reproduced with cherry too" + {:at 11}) +(gitea/issue-create! + gs-forge + "alice" + "proj" + "alice" + "Docs update" + "documentation needs love" + {:created-at 12}) +(gitea/pr-create! + gs-forge + "alice" + "proj" + "bob" + "Improve search ranking" + "feat" + "main" + "tfidf ranking for results" + {}) + +; ── corpus construction ────────────────────────────────────────────── + +(define gs-corp-code (gitea/repo-docs gs-forge "alice" "proj" (list "code"))) +(define + gs-corp-ip + (gitea/repo-docs gs-forge "alice" "proj" (list "issue" "pr"))) +(define + gs-corp-all + (gitea/repo-docs gs-forge "alice" "proj" gitea/search-kinds-all)) +(define gs-corp-anon (gitea/visible-docs gs-forge nil gitea/search-kinds-all)) +(define + gs-corp-own + (gitea/visible-docs gs-forge "alice" gitea/search-kinds-all)) + +(gitea-search-test "code docs" (len gs-corp-code) 3) +(gitea-search-test "issue+pr docs" (len gs-corp-ip) 3) +(gitea-search-test "all docs" (len gs-corp-all) 6) +(gitea-search-test + "empty repo corpus" + (gitea/code-docs gs-forge "alice" "empty") + (list)) +(gitea-search-test + "anon corpus excludes private" + (len (filter (fn (d) (= (get d :repo) "alice/sec")) gs-corp-anon)) + 0) +(gitea-search-test + "owner corpus includes private" + (len (filter (fn (d) (= (get d :repo) "alice/sec")) gs-corp-own)) + 1) + +; ── ONE evaluation, thirteen queries over five corpora ─────────────── + +(define + gs-R + (gitea/search-multi + (list gs-corp-code gs-corp-ip gs-corp-all gs-corp-anon gs-corp-own) + (list + {:n 20 :query "banana" :corpus 0} + {:n 20 :query "forge" :corpus 0} + {:n 20 :query "banana OR cherry" :corpus 0} + {:n 20 :query "nosuchterm" :corpus 0} + {:n 20 :query "banana" :corpus 1} + {:n 20 :query "cherry" :corpus 1} + {:n 20 :query "ranking" :corpus 1} + {:n 20 :query "search AND banana" :corpus 1} + {:n 20 :query "documentation" :corpus 1} + {:n 20 :query "search" :corpus 2} + {:n 2 :query "search" :corpus 2} + {:n 20 :query "banana" :corpus 3} + {:n 20 :query "banana" :corpus 4}))) + +(gitea-search-test + "code: unique term" + (nth gs-R 0) + (list {:kind "code" :ref "src/main.sx"})) +(gitea-search-test + "code: common term hits all three" + (len (nth gs-R 1)) + 3) +(gitea-search-test "code: OR query" (nth gs-R 2) (list {:kind "code" :ref "src/main.sx"})) +(gitea-search-test "code: no hits" (nth gs-R 3) (list)) + +(gitea-search-test + "issues: body term" + (nth gs-R 4) + (list {:kind "issue" :ref "1"})) +(gitea-search-test + "issues: comment text indexed" + (nth gs-R 5) + (list {:kind "issue" :ref "1"})) +(gitea-search-test "prs: body term" (nth gs-R 6) (list {:kind "pr" :ref "3"})) +(gitea-search-test + "issues: AND query" + (nth gs-R 7) + (list {:kind "issue" :ref "1"})) +(gitea-search-test + "issues: title+body of second" + (len (filter (fn (r) (= r {:kind "issue" :ref "2"})) (nth gs-R 8))) + 1) + +(gitea-search-test + "mixed kinds found" + (len (nth gs-R 9)) + 3) +(gitea-search-test + "take-n limits results" + (len (nth gs-R 10)) + 2) + +(gitea-search-test + "global anon excludes private" + (len + (filter (fn (r) (= (get r :repo) "alice/sec")) (nth gs-R 11))) + 0) +(gitea-search-test + "global anon finds public code+issue" + (len (nth gs-R 11)) + 2) +(gitea-search-test + "global owner sees private" + (len + (filter (fn (r) (= (get r :repo) "alice/sec")) (nth gs-R 12))) + 1) +(gitea-search-test + "global owner total" + (len (nth gs-R 12)) + 3) + +; empty corpora short-circuit without an evaluation +(gitea-search-test + "empty corpus searches empty" + (gitea/search-repo + gs-forge + "alice" + "empty" + "banana" + gitea/search-kinds-all + 10) + (list)) + +; ── web (one haskell evaluation per request) ───────────────────────── + +(define gs-app (gitea/app gs-forge)) +(define gs-hdr (fn (tok) (if (nil? tok) {} {:authorization (str "Bearer " tok)}))) +(define + gs-get + (fn (target tok) (gs-app (dream-request "GET" target (gs-hdr tok) "")))) + +(define gs-page (gs-get "/alice/proj/search?q=banana" nil)) +(gitea-search-test "search page 200" (dream-status gs-page) 200) +(gitea-search-test + "search page links the hit" + (contains? (dream-resp-body gs-page) "src/main.sx") + true) + +(gitea-search-test + "search page kind filter" + (contains? + (dream-resp-body (gs-get "/alice/proj/search?q=banana&kind=issue" nil)) + "issues/1") + true) +(gitea-search-test + "search page missing q 400" + (dream-status (gs-get "/alice/proj/search" nil)) + 400) +(gitea-search-test + "private search anon 404" + (dream-status (gs-get "/alice/sec/search?q=banana" nil)) + 404) + +(gitea-search-test + "api repo search" + (dream-json-parse + (dream-resp-body + (gs-get "/api/repos/alice/proj/search?q=cherry&kind=issue" nil))) + (list {:kind "issue" :ref "1"})) +(gitea-search-test + "api repo search missing q 400" + (dream-status (gs-get "/api/repos/alice/proj/search" nil)) + 400) + +(define gs-glob-anon (gs-get "/api/search?q=banana" nil)) +(gitea-search-test + "api global anon count" + (len (dream-json-parse (dream-resp-body gs-glob-anon))) + 2) +(define gs-glob-own (gs-get "/api/search?q=banana" "tok-a")) +(gitea-search-test + "api global authed count" + (len (dream-json-parse (dream-resp-body gs-glob-own))) + 3) diff --git a/lib/gitea/tests/wire.sx b/lib/gitea/tests/wire.sx new file mode 100644 index 00000000..f944fa79 --- /dev/null +++ b/lib/gitea/tests/wire.sx @@ -0,0 +1,490 @@ +; lib/gitea/tests/wire.sx — Phase 3: pkt-line framing, object closure, +; smart-HTTP endpoints (info/refs, upload-pack, receive-pack), and the +; client (ls-remote/clone!/fetch!/push!) syncing two in-memory forges. + +(define gitea-wire-pass 0) +(define gitea-wire-fail 0) +(define gitea-wire-fails (list)) + +(define + gitea-wire-test + (fn + (name actual expected) + (if + (= actual expected) + (set! gitea-wire-pass (+ gitea-wire-pass 1)) + (begin + (set! gitea-wire-fail (+ gitea-wire-fail 1)) + (set! gitea-wire-fails (append gitea-wire-fails (list {:name name :expected (inspect expected) :actual (inspect actual)}))))))) + +; ── pkt-line framing ───────────────────────────────────────────────── + +(gitea-wire-test "hex4 small" (gitea/hex4 5) "0005") +(gitea-wire-test "hex4 max" (gitea/hex4 65535) "ffff") +(gitea-wire-test "hex4-parse" (gitea/hex4-parse "001a") 26) +(gitea-wire-test + "hex4 round trip" + (gitea/hex4-parse (gitea/hex4 4242)) + 4242) +(gitea-wire-test "pkt frames with length" (gitea/pkt "hi") "0006hi") +(gitea-wire-test + "pkt-sections round trip" + (gitea/pkt-sections (gitea/pkt-render (list (list "a" "bc") (list "z")))) + (list (list "a" "bc") (list "z"))) +(gitea-wire-test "pkt-sections empty" (gitea/pkt-sections "") (list)) +(gitea-wire-test + "pkt-sections flush only" + (gitea/pkt-sections "0000") + (list (list))) +(gitea-wire-test "pkt-fits? small" (gitea/pkt-fits? "x") true) + +(define + gw-big + (reduce + (fn (acc i) (str acc acc)) + "xxxxxxxxxx" + (list + 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 + 10 + 11 + 12 + 13))) +(gitea-wire-test "pkt-fits? huge payload" (gitea/pkt-fits? gw-big) false) + +; ── forge A with history ───────────────────────────────────────────── + +(define gw-db (persist/mem-backend)) +(define gw-forge (gitea/forge gw-db)) +(gitea/user-create! gw-forge "alice") +(gitea/user-create! gw-forge "bob") +(gitea/user-create! gw-forge "rope") +(gitea/token-create! gw-forge "alice" "tok-a") +(gitea/token-create! gw-forge "bob" "tok-b") +(gitea/token-create! gw-forge "rope" "tok-r") +(gitea/repo-create! gw-forge "alice" "lib" {}) +(gitea/collab-add! gw-forge "alice" "lib" "rope" "read") + +(define gw-ga (gitea/repo-git gw-forge "alice" "lib")) +(git/add! gw-ga "README.md" "hello\n") +(git/add! gw-ga "src/a.txt" "alpha\n") +(define gw-c1 (git/commit! gw-ga {:message "init" :time 1 :author "alice"})) +(git/add! gw-ga "src/a.txt" "alpha2\n") +(define gw-c2 (git/commit! gw-ga {:message "more" :time 2 :author "alice"})) +(git/tag! gw-ga "v1" {:message "rel" :time 3}) +(define gw-tag-cid (git/tag-get gw-ga "v1")) +(git/branch-create! gw-ga "dev" gw-c1) + +; ── closure ────────────────────────────────────────────────────────── + +; c1 = commit + root tree + src tree + 2 blobs +(gitea-wire-test + "closure of c1" + (len (gitea/closure-list gw-ga (list gw-c1))) + 5) +; c2 adds commit + new root + new src + new blob +(gitea-wire-test + "closure of c2" + (len (gitea/closure-list gw-ga (list gw-c2))) + 9) +(gitea-wire-test + "pack-cids c2 given c1" + (len (gitea/pack-cids gw-ga (list gw-c2) (list gw-c1))) + 4) +(gitea-wire-test + "pack includes tip commit" + (contains? (gitea/pack-cids gw-ga (list gw-c2) (list gw-c1)) gw-c2) + true) +(gitea-wire-test + "pack excludes had commit" + (contains? (gitea/pack-cids gw-ga (list gw-c2) (list gw-c1)) gw-c1) + false) +(gitea-wire-test + "closure through tag object" + (len (gitea/closure-list gw-ga (list gw-tag-cid))) + 10) +(gitea-wire-test + "closure-complete? tip" + (gitea/closure-complete? gw-ga (list gw-c2)) + true) +(gitea-wire-test + "closure-complete? missing cid" + (gitea/closure-complete? gw-ga (list "sx1:doesnotexist")) + false) +(gitea-wire-test + "obj-refs of commit" + (len (gitea/obj-refs (git/read gw-ga gw-c2))) + 2) + +; ── pack line verification ─────────────────────────────────────────── + +(gitea-wire-test + "pack-line parses and verifies" + (get (gitea/pack-line-parse (gitea/pack-line gw-ga gw-c1)) :cid) + gw-c1) +(gitea-wire-test + "pack-line tamper detected" + (get + (gitea/pack-line-parse (str gw-c1 " " (serialize (git/blob "evil")))) + :error) + "cid-mismatch") +(gitea-wire-test + "unpack! rejects tampered pack" + (get + (gitea/unpack! + gw-ga + (list (str gw-c1 " " (serialize (git/blob "evil"))))) + :error) + "cid-mismatch") + +; ── server endpoints ───────────────────────────────────────────────── + +(define gw-app (gitea/forge-app gw-forge)) +(define gw-hdr (fn (tok) (if (nil? tok) {} {:authorization (str "Bearer " tok)}))) +(define + gw-get + (fn (target tok) (gw-app (dream-request "GET" target (gw-hdr tok) "")))) +(define + gw-post + (fn + (target tok body) + (gw-app (dream-request "POST" target (gw-hdr tok) body)))) + +(gitea-wire-test + "info/refs 200" + (dream-status (gw-get "/alice/lib/info/refs" nil)) + 200) +(gitea-wire-test + "info/refs advertises main" + (contains? + (dream-resp-body (gw-get "/alice/lib/info/refs" nil)) + (str gw-c2 " heads/main")) + true) +(gitea-wire-test + "info/refs advertises dev" + (contains? + (dream-resp-body (gw-get "/alice/lib/info/refs" nil)) + (str gw-c1 " heads/dev")) + true) +(gitea-wire-test + "info/refs advertises tag" + (contains? + (dream-resp-body (gw-get "/alice/lib/info/refs" nil)) + (str gw-tag-cid " tags/v1")) + true) +(gitea-wire-test + "info/refs advertises HEAD" + (contains? + (dream-resp-body (gw-get "/alice/lib/info/refs" nil)) + "@ heads/main") + true) +(gitea-wire-test + "info/refs unknown repo 404" + (dream-status (gw-get "/alice/none/info/refs" nil)) + 404) + +(define + gw-up-body + (fn + (wants haves) + (gitea/pkt-render + (list + (concat + (map (fn (c) (str "want " c)) wants) + (map (fn (c) (str "have " c)) haves)))))) + +(define + gw-up-lines + (fn + (resp) + (let + ((s (gitea/pkt-sections (dream-resp-body resp)))) + (if (empty? s) (list) (first s))))) + +(gitea-wire-test + "upload-pack full clone size" + (len + (gw-up-lines + (gw-post + "/alice/lib/git-upload-pack" + nil + (gw-up-body (list gw-c2) (list))))) + 9) +(gitea-wire-test + "upload-pack incremental size" + (len + (gw-up-lines + (gw-post + "/alice/lib/git-upload-pack" + nil + (gw-up-body (list gw-c2) (list gw-c1))))) + 4) +(gitea-wire-test + "upload-pack lines all verify" + (len + (filter + (fn (l) (get (gitea/pack-line-parse l) :error)) + (gw-up-lines + (gw-post + "/alice/lib/git-upload-pack" + nil + (gw-up-body (list gw-c2) (list)))))) + 0) + +(gitea-wire-test + "receive-pack anon 401" + (dream-status + (gw-post + "/alice/lib/git-receive-pack" + nil + (gitea/pkt-render (list (list) (list))))) + 401) +(gitea-wire-test + "receive-pack read-only 403" + (dream-status + (gw-post + "/alice/lib/git-receive-pack" + "tok-r" + (gitea/pkt-render (list (list) (list))))) + 403) + +; private repo wire gating +(gitea/repo-create! gw-forge "alice" "priv" {:visibility "private"}) +(define gw-gp (gitea/repo-git gw-forge "alice" "priv")) +(git/add! gw-gp "p.txt" "private\n") +(git/commit! gw-gp {:message "p" :time 1 :author "alice"}) + +(gitea-wire-test + "private info/refs anon 404" + (dream-status (gw-get "/alice/priv/info/refs" nil)) + 404) +(gitea-wire-test + "private info/refs owner 200" + (dream-status (gw-get "/alice/priv/info/refs" "tok-a")) + 200) +(gitea-wire-test + "private upload-pack anon 404" + (dream-status + (gw-post "/alice/priv/git-upload-pack" nil (gw-up-body (list) (list)))) + 404) + +; ── client: ls-remote ──────────────────────────────────────────────── + +(define gw-remote-anon (gitea/remote gw-app "alice" "lib" nil)) +(define gw-remote-bob (gitea/remote gw-app "alice" "lib" "tok-b")) +(define gw-remote-rope (gitea/remote gw-app "alice" "lib" "tok-r")) + +(define gw-ls (gitea/ls-remote gw-remote-anon)) +(gitea-wire-test "ls-remote head" (get gw-ls :head) "heads/main") +(gitea-wire-test "ls-remote main" (get (get gw-ls :refs) "heads/main") gw-c2) +(gitea-wire-test "ls-remote dev" (get (get gw-ls :refs) "heads/dev") gw-c1) +(gitea-wire-test + "ls-remote tag" + (get (get gw-ls :refs) "tags/v1") + gw-tag-cid) +(gitea-wire-test + "ls-remote unknown repo" + (gitea/ls-remote (gitea/remote gw-app "alice" "none" nil)) + nil) + +; ── client: clone into forge B ─────────────────────────────────────── + +(define gw-db2 (persist/mem-backend)) +(define gw-forge2 (gitea/forge gw-db2)) +(gitea/user-create! gw-forge2 "bob") + +(define + gw-clone + (gitea/clone! gw-forge2 "bob" "lib" gw-remote-anon {})) +(gitea-wire-test "clone returns record" (get gw-clone :owner) "bob") + +(define gw-gb (gitea/repo-git gw-forge2 "bob" "lib")) +(gitea-wire-test "clone main" (git/branch-get gw-gb "main") gw-c2) +(gitea-wire-test "clone dev" (git/branch-get gw-gb "dev") gw-c1) +(gitea-wire-test "clone tag" (git/tag-get gw-gb "v1") gw-tag-cid) +(gitea-wire-test "clone HEAD" (git/head-target gw-gb) "heads/main") +(gitea-wire-test + "clone default branch recorded" + (get (gitea/repo-get gw-forge2 "bob" "lib") :default-branch) + "main") +(gitea-wire-test "clone log" (git/log gw-gb gw-c2) (list gw-c2 gw-c1)) +(gitea-wire-test + "clone blob content" + (git/blob-data + (git/read gw-gb (get (gitea/tree-at gw-gb gw-c2 "src/a.txt") :cid))) + "alpha2\n") +(gitea-wire-test + "clone closure complete" + (gitea/closure-complete? gw-gb (list gw-c2)) + true) +(gitea-wire-test + "clone again conflicts" + (get + (gitea/clone! gw-forge2 "bob" "lib" gw-remote-anon {}) + :conflict) + true) +(gitea-wire-test + "clone unreachable remote errors" + (get + (gitea/clone! + gw-forge2 + "bob" + "ghost" + (gitea/remote gw-app "alice" "none" nil) + {}) + :error) + 404) +(gitea-wire-test + "failed clone leaves no repo" + (gitea/repo-exists? gw-forge2 "bob" "ghost") + false) + +; ── client: fetch after upstream moves ─────────────────────────────── + +(git/add! gw-ga "src/c.txt" "gamma\n") +(define gw-c3 (git/commit! gw-ga {:message "third" :time 4 :author "alice"})) + +(define gw-fetch1 (gitea/fetch! gw-remote-anon gw-gb)) +(gitea-wire-test + "fetch stores new objects" + (> (get gw-fetch1 :stored) 0) + true) +(gitea-wire-test "fetch moves main" (git/branch-get gw-gb "main") gw-c3) +(gitea-wire-test + "fetch closure complete" + (gitea/closure-complete? gw-gb (list gw-c3)) + true) +(gitea-wire-test + "fetch up-to-date is no-op" + (get (gitea/fetch! gw-remote-anon gw-gb) :stored) + 0) + +; ── client: push ───────────────────────────────────────────────────── + +; bob gets write on the upstream, commits locally, pushes +(gitea/collab-add! gw-forge "alice" "lib" "bob" "write") +(git/checkout! gw-gb "main") +(git/add! gw-gb "src/b.txt" "beta\n") +(define gw-c4 (git/commit! gw-gb {:message "from-bob" :time 5 :author "bob"})) + +(gitea-wire-test + "push ok" + (get (gitea/push! gw-remote-bob gw-gb "heads/main") :ok) + true) +(gitea-wire-test + "push moved upstream main" + (git/branch-get gw-ga "main") + gw-c4) +(gitea-wire-test + "upstream has pushed objects" + (gitea/closure-complete? gw-ga (list gw-c4)) + true) + +; push auth: anon 401, read-only 403 +(gitea-wire-test + "push anon rejected" + (get (gitea/push! gw-remote-anon gw-gb "heads/main") :error) + 401) +(gitea-wire-test + "push read-only rejected" + (get (gitea/push! gw-remote-rope gw-gb "heads/main") :error) + 403) + +; non-fast-forward: upstream moves on while bob commits on the old tip +(git/checkout! gw-ga "main") +(git/add! gw-ga "src/d.txt" "delta\n") +(define gw-c5 (git/commit! gw-ga {:message "upstream-moves" :time 6 :author "alice"})) + +(git/add! gw-gb "src/e.txt" "eps\n") +(define gw-c4b (git/commit! gw-gb {:message "bob-diverges" :time 7 :author "bob"})) + +(gitea-wire-test + "push non-fast-forward rejected" + (get (gitea/push! gw-remote-bob gw-gb "heads/main") :ng) + "non-fast-forward") +(gitea-wire-test + "upstream main unchanged after ng" + (git/branch-get gw-ga "main") + gw-c5) + +; recover: fetch (mirror moves local main to upstream), rebuild, push +(gitea/fetch! gw-remote-bob gw-gb) +(gitea-wire-test + "fetch after ng syncs main" + (git/branch-get gw-gb "main") + gw-c5) +(git/checkout! gw-gb "main") +(git/add! gw-gb "src/e.txt" "eps\n") +(define gw-c6 (git/commit! gw-gb {:message "bob-rebased" :time 8 :author "bob"})) +(gitea-wire-test + "push after sync ok" + (get (gitea/push! gw-remote-bob gw-gb "heads/main") :ok) + true) +(gitea-wire-test + "upstream at bob's rebased tip" + (git/branch-get gw-ga "main") + gw-c6) + +; branch create / delete over the wire +(git/branch-create! gw-gb "feat" gw-c6) +(gitea-wire-test + "push new branch" + (get (gitea/push! gw-remote-bob gw-gb "heads/feat") :ok) + true) +(gitea-wire-test + "upstream sees new branch" + (git/branch-get gw-ga "feat") + gw-c6) +(gitea-wire-test + "push delete branch" + (get (gitea/push-delete! gw-remote-bob gw-gb "heads/feat") :ok) + true) +(gitea-wire-test "upstream branch deleted" (git/branch-get gw-ga "feat") nil) + +; tag push +(git/tag-lightweight! gw-gb "v2") +(gitea-wire-test + "push tag" + (get (gitea/push! gw-remote-bob gw-gb "tags/v2") :ok) + true) +(gitea-wire-test "upstream sees tag" (git/tag-get gw-ga "v2") gw-c6) + +; guard rails +(gitea-wire-test + "push unknown local ref" + (get (gitea/push! gw-remote-bob gw-gb "heads/nope") :error) + "no-such-local-ref") +(gitea-wire-test + "apply-cmd rejects non-shared ref" + (gitea/apply-cmd! gw-ga {:name "bogus/x" :new gw-c1 :old "-"}) + "ng bogus/x invalid-ref") +(gitea-wire-test + "apply-cmd rejects missing objects" + (gitea/apply-cmd! gw-ga {:name "heads/zzz" :new "sx1:missing" :old "-"}) + "ng heads/zzz missing-objects") + +; private repo full round trip with credentials +(define gw-remote-priv (gitea/remote gw-app "alice" "priv" "tok-a")) +(gitea/user-create! gw-forge2 "alice") +(define + gw-pclone + (gitea/clone! gw-forge2 "alice" "priv" gw-remote-priv {:visibility "private"})) +(gitea-wire-test "private clone with token" (get gw-pclone :owner) "alice") +(gitea-wire-test + "private clone anon fails" + (get + (gitea/clone! + gw-forge2 + "alice" + "priv2" + (gitea/remote gw-app "alice" "priv" nil) + {}) + :error) + 404) diff --git a/lib/gitea/web.sx b/lib/gitea/web.sx new file mode 100644 index 00000000..09af5b00 --- /dev/null +++ b/lib/gitea/web.sx @@ -0,0 +1,520 @@ +; lib/gitea/web.sx — sx-gitea Phases 1+2: browse views over dream, gated +; by access control. +; +; Pure request -> response handlers: repo list, repo home, tree/blob/raw +; browse at any ref (branch, tag, or cid), commit log, single-commit diff, +; plus a JSON API for repo create/list/delete and collaborator management. +; +; Gating: every repo route requires "read" (a miss is a 404 — private +; repos are indistinguishable from absent ones); mutations require the +; caller to authenticate (bearer token) and hold the right role: create +; needs the owner (or org admin), delete and collaborator management need +; "admin". 401 = no credentials, 403 = authenticated but not allowed. +; +; Later modules (wire, issues, pr, activity, ...) extend the app by +; appending a routes pack to gitea/route-packs at load time; gitea/app +; serves them all, with every /api/* route hoisted ahead of the wildcard +; /:owner/:name patterns so a pack can never be shadowed. +; +; Requires: lib/gitea/{repo,access}.sx, lib/dream/{types,router,middleware, +; error,html,json,auth,api}.sx + +; ── html scaffolding ───────────────────────────────────────────────── + +(define + gitea/w-page + (fn + (title body) + (dream-html + (str + "" + (dream-escape title) + "" + body + "")))) + +(define + gitea/w-repo-link + (fn + (full) + (str "

  • " (dream-escape full) "
  • "))) + +; ── auth helpers ───────────────────────────────────────────────────── + +(define + gitea/w-user + (fn + (forge req) + (let + ((tok (dream-bearer-token req))) + (if (nil? tok) nil (gitea/token-user forge tok))))) + +(define + gitea/w-json-status + (fn (status v) (dream-response status {:content-type "application/json"} (dream-json-encode v)))) + +(define + gitea/w-unauthorized + (fn () (gitea/w-json-status 401 {:error "unauthorized"}))) +(define + gitea/w-forbidden + (fn () (gitea/w-json-status 403 {:error "forbidden"}))) + +; can the requester read this repo? (false covers missing repos too) +(define + gitea/w-readable? + (fn + (forge req owner name) + (gitea/can? forge (gitea/w-user forge req) "read" owner name))) + +; ── pages ──────────────────────────────────────────────────────────── + +(define + gitea/w-index + (fn + (forge req) + (gitea/w-page + "repositories" + (str + "

    Repositories

      " + (join + "" + (map + gitea/w-repo-link + (gitea/visible-repos forge (gitea/w-user forge req)))) + "
    ")))) + +(define + gitea/w-branch-item + (fn + (owner name b) + (str + "
  • " + (dream-escape b) + "
  • "))) + +(define + gitea/w-repo-home + (fn + (forge req) + (let + ((owner (dream-param req "owner")) (name (dream-param req "name"))) + (if + (not (gitea/w-readable? forge req owner name)) + (dream-not-found) + (let + ((rec (gitea/repo-get forge owner name)) + (branches (git/branches (gitea/repo-git forge owner name)))) + (gitea/w-page + (str owner "/" name) + (str + "

    " + (dream-escape (str owner "/" name)) + "

    " + "

    " + (dream-escape (or (get rec :description) "")) + "

    " + "

    visibility: " + (dream-escape (get rec :visibility)) + "

    " + (if + (empty? branches) + "

    empty repository

    " + (str + "

    Branches

      " + (join + "" + (map + (fn (b) (gitea/w-branch-item owner name b)) + branches)) + "
    "))))))))) + +(define + gitea/w-branches + (fn + (forge req) + (let + ((owner (dream-param req "owner")) (name (dream-param req "name"))) + (if + (not (gitea/w-readable? forge req owner name)) + (dream-not-found) + (gitea/w-page + (str owner "/" name " branches") + (str + "

    Branches

      " + (join + "" + (map + (fn (b) (gitea/w-branch-item owner name b)) + (git/branches (gitea/repo-git forge owner name)))) + "
    ")))))) + +; resolve the owner/name/ref/** of a browse request down to a tree entry; +; nil on any miss (unreadable repo, bad ref, bad path) +(define + gitea/w-entry + (fn + (forge req) + (let + ((owner (dream-param req "owner")) + (name (dream-param req "name")) + (ref (dream-param req "ref")) + (path (or (dream-param req "**") ""))) + (if + (not (gitea/w-readable? forge req owner name)) + nil + (let + ((grepo (gitea/repo-git forge owner name))) + (let + ((cid (gitea/resolve-ref grepo ref))) + (if + (nil? cid) + nil + (let + ((entry (gitea/tree-at grepo cid path))) + (if (nil? entry) nil {:name name :path path :grepo grepo :entry entry :owner owner :ref ref}))))))))) + +(define + gitea/w-entry-item + (fn + (hit n kind) + (let + ((base (if (equal? kind "tree") "tree" "blob"))) + (let + ((sub (if (equal? (get hit :path) "") n (str (get hit :path) "/" n)))) + (str + "
  • " + (dream-escape n) + "
  • "))))) + +(define + gitea/w-tree + (fn + (forge req) + (let + ((hit (gitea/w-entry forge req))) + (if + (or (nil? hit) (not (equal? (get (get hit :entry) :kind) "tree"))) + (dream-not-found) + (let + ((tree (git/read (get hit :grepo) (get (get hit :entry) :cid)))) + (gitea/w-page + (str (get hit :owner) "/" (get hit :name) ": /" (get hit :path)) + (str + "

    " + (dream-escape (str (get hit :owner) "/" (get hit :name))) + "

    " + "

    /" + (dream-escape (get hit :path)) + "

    " + "
      " + (join + "" + (map + (fn + (n) + (gitea/w-entry-item + hit + n + (git/entry-kind (git/tree-entry-for tree n)))) + (git/tree-names tree))) + "
    "))))))) + +(define + gitea/w-blob + (fn + (forge req) + (let + ((hit (gitea/w-entry forge req))) + (if + (or (nil? hit) (not (equal? (get (get hit :entry) :kind) "blob"))) + (dream-not-found) + (let + ((data (git/blob-data (git/read (get hit :grepo) (get (get hit :entry) :cid))))) + (gitea/w-page + (str (get hit :owner) "/" (get hit :name) ": " (get hit :path)) + (str + "

    " + (dream-escape (get hit :path)) + "

    " + "
    "
    +              (dream-escape data)
    +              "
    "))))))) + +(define + gitea/w-raw + (fn + (forge req) + (let + ((hit (gitea/w-entry forge req))) + (if + (or (nil? hit) (not (equal? (get (get hit :entry) :kind) "blob"))) + (dream-not-found) + (dream-text + (git/blob-data + (git/read (get hit :grepo) (get (get hit :entry) :cid)))))))) + +(define + gitea/w-commit-item + (fn + (grepo owner name c) + (let + ((obj (git/read grepo c))) + (str + "
  • " + (dream-escape (or (git/commit-message obj) "")) + " " + c + "
  • ")))) + +(define + gitea/w-commits + (fn + (forge req) + (let + ((owner (dream-param req "owner")) + (name (dream-param req "name")) + (ref (dream-param req "ref"))) + (if + (not (gitea/w-readable? forge req owner name)) + (dream-not-found) + (let + ((grepo (gitea/repo-git forge owner name))) + (let + ((cid (gitea/resolve-ref grepo ref))) + (if + (nil? cid) + (dream-not-found) + (gitea/w-page + (str owner "/" name " commits") + (str + "

    Commits

      " + (join + "" + (map + (fn (c) (gitea/w-commit-item grepo owner name c)) + (git/log grepo cid))) + "
    "))))))))) + +; single commit: message/author/parents, plus the diff against the first +; parent (root commits list their files instead) +(define + gitea/w-commit + (fn + (forge req) + (let + ((owner (dream-param req "owner")) + (name (dream-param req "name")) + (cidp (dream-param req "cid"))) + (if + (not (gitea/w-readable? forge req owner name)) + (dream-not-found) + (let + ((grepo (gitea/repo-git forge owner name))) + (let + ((obj (git/read grepo cidp))) + (if + (or (nil? obj) (not (git/commit? obj))) + (dream-not-found) + (let + ((parents (git/commit-parents obj))) + (let + ((detail (if (empty? parents) (str "

    Files

      " (join "" (map (fn (p) (str "
    • " (dream-escape p) "
    • ")) (artdag/sort-strings (keys (git/tree-flatten grepo (git/commit-tree obj)))))) "
    ") (str "
    " (dream-escape (git/commit-diff-unified grepo (first parents) cidp)) "
    ")))) + (gitea/w-page + (str "commit " cidp) + (str + "

    " + (dream-escape (or (git/commit-message obj) "")) + "

    " + "

    author: " + (dream-escape (or (git/commit-author obj) "")) + "

    " + "

    cid: " + cidp + "

    " + detail))))))))))) + +; ── json api ───────────────────────────────────────────────────────── + +(define + gitea/w-api-repos + (fn + (forge req) + (dream-json-value (gitea/visible-repos forge (gitea/w-user forge req))))) + +(define + gitea/w-api-repo-create + (fn + (forge req) + (let + ((user (gitea/w-user forge req))) + (if + (nil? user) + (gitea/w-unauthorized) + (let + ((body (dream-json-body req))) + (let + ((owner (get body :owner))) + (cond + ((not (gitea/owner-exists? forge owner)) + (gitea/w-json-status 400 {:error "no-such-owner"})) + ((not (gitea/create-allowed? forge user owner)) + (gitea/w-forbidden)) + (else + (let + ((res (gitea/repo-create! forge owner (get body :name) {:description (or (get body :description) "") :created-at (or (get body :created-at) 0) :visibility (or (get body :visibility) "public")}))) + (cond + ((get res :conflict) + (gitea/w-json-status 409 {:error "exists"})) + ((get res :error) + (gitea/w-json-status 400 {:error (get res :error)})) + (else (gitea/w-json-status 201 {:name (get res :name) :owner (get res :owner) :visibility (get res :visibility)})))))))))))) + +(define + gitea/w-api-repo-delete + (fn + (forge req) + (let + ((owner (dream-param req "owner")) (name (dream-param req "name"))) + (let + ((user (gitea/w-user forge req))) + (cond + ((not (gitea/can? forge user "read" owner name)) + (dream-not-found)) + ((nil? user) (gitea/w-unauthorized)) + ((not (gitea/can? forge user "admin" owner name)) + (gitea/w-forbidden)) + (else + (begin + (gitea/repo-delete! forge owner name) + (dream-json-value {:deleted true})))))))) + +(define + gitea/w-api-collab-put + (fn + (forge req) + (let + ((owner (dream-param req "owner")) + (name (dream-param req "name")) + (cuser (dream-param req "user"))) + (let + ((user (gitea/w-user forge req))) + (cond + ((not (gitea/can? forge user "read" owner name)) + (dream-not-found)) + ((nil? user) (gitea/w-unauthorized)) + ((not (gitea/can? forge user "admin" owner name)) + (gitea/w-forbidden)) + (else + (let + ((role (or (get (dream-json-body req) :role) "read"))) + (let + ((res (gitea/collab-add! forge owner name cuser role))) + (if + (get res :error) + (gitea/w-json-status 400 {:error (get res :error)}) + (dream-json-value {:role role :user cuser})))))))))) + +(define + gitea/w-api-collab-delete + (fn + (forge req) + (let + ((owner (dream-param req "owner")) + (name (dream-param req "name")) + (cuser (dream-param req "user"))) + (let + ((user (gitea/w-user forge req))) + (cond + ((not (gitea/can? forge user "read" owner name)) + (dream-not-found)) + ((nil? user) (gitea/w-unauthorized)) + ((not (gitea/can? forge user "admin" owner name)) + (gitea/w-forbidden)) + ((gitea/collab-remove! forge owner name cuser) + (dream-json-value {:deleted true})) + (else (dream-not-found))))))) + +; ── routes ─────────────────────────────────────────────────────────── + +(define + gitea/routes + (fn + (forge) + (list + (dream-get "/" (fn (req) (gitea/w-index forge req))) + (dream-get "/api/repos" (fn (req) (gitea/w-api-repos forge req))) + (dream-post + "/api/repos" + (fn (req) (gitea/w-api-repo-create forge req))) + (dream-delete + "/api/repos/:owner/:name" + (fn (req) (gitea/w-api-repo-delete forge req))) + (dream-put + "/api/repos/:owner/:name/collab/:user" + (fn (req) (gitea/w-api-collab-put forge req))) + (dream-delete + "/api/repos/:owner/:name/collab/:user" + (fn (req) (gitea/w-api-collab-delete forge req))) + (dream-get "/:owner/:name" (fn (req) (gitea/w-repo-home forge req))) + (dream-get + "/:owner/:name/branches" + (fn (req) (gitea/w-branches forge req))) + (dream-get + "/:owner/:name/commits/:ref" + (fn (req) (gitea/w-commits forge req))) + (dream-get + "/:owner/:name/commit/:cid" + (fn (req) (gitea/w-commit forge req))) + (dream-get + "/:owner/:name/tree/:ref/**" + (fn (req) (gitea/w-tree forge req))) + (dream-get + "/:owner/:name/blob/:ref/**" + (fn (req) (gitea/w-blob forge req))) + (dream-get + "/:owner/:name/raw/:ref/**" + (fn (req) (gitea/w-raw forge req)))))) + +; extension point: wire/issues/pr/activity/... append their packs at load +(define gitea/route-packs (list gitea/routes)) + +; every /api/* route (from any pack) dispatches before the wildcard +; /:owner/:name patterns, so later packs can add API endpoints freely +(define + gitea/all-routes + (fn + (forge) + (let + ((rs (reduce (fn (acc pack) (concat acc (pack forge))) (list) gitea/route-packs))) + (concat + (filter (fn (r) (starts-with? (dream-route-path r) "/api/")) rs) + (filter + (fn (r) (not (starts-with? (dream-route-path r) "/api/"))) + rs))))) + +(define gitea/app (fn (forge) (dream-make-app (gitea/all-routes forge)))) diff --git a/lib/gitea/wire.sx b/lib/gitea/wire.sx new file mode 100644 index 00000000..90e6ee6b --- /dev/null +++ b/lib/gitea/wire.sx @@ -0,0 +1,554 @@ +; lib/gitea/wire.sx — sx-gitea Phase 3: smart-HTTP wire protocol. +; +; git-style smart HTTP over the NATIVE sx-git object model: pkt-line +; framing (byte-compatible with git's framing), ref advertisement, +; upload-pack (clone/fetch) and receive-pack (push). Objects travel as +; " " pkt lines — the receiver re-derives the CID +; from the bytes, so a pack can't lie about its contents. SHA-1/packfile +; byte compat for stock git clients stays in lib/git/{export,import}.sx. +; +; Endpoints (registered on gitea/route-packs): +; GET /:owner/:name/info/refs read-gated ref advertisement +; POST /:owner/:name/git-upload-pack read-gated; wants/haves -> pack +; POST /:owner/:name/git-receive-pack write-gated; commands+pack -> statuses +; +; A client (gitea/remote over any dream app fn) provides ls-remote / +; clone! / fetch! / push! / push-delete! — two in-memory forges can sync +; with no sockets anywhere. +; +; Limits: one object per pkt line => objects over ~64KB need side-band +; chunking (future extension); gitea/pkt-fits? reports this. +; +; Requires: lib/gitea/{repo,access,web}.sx and their stacks, plus +; sx-parse (spec/parser.sx on the OCaml server host). + +; ── pkt-line framing ───────────────────────────────────────────────── + +(define gitea/hex-chars "0123456789abcdef") + +(define + gitea/hex4 + (fn + (n) + (str + (char-at gitea/hex-chars (mod (quotient n 4096) 16)) + (char-at gitea/hex-chars (mod (quotient n 256) 16)) + (char-at gitea/hex-chars (mod (quotient n 16) 16)) + (char-at gitea/hex-chars (mod n 16))))) + +(define gitea/hex-val (fn (c) (index-of gitea/hex-chars (lower c)))) + +(define + gitea/hex4-parse + (fn + (s) + (+ + (* 4096 (gitea/hex-val (char-at s 0))) + (* 256 (gitea/hex-val (char-at s 1))) + (* 16 (gitea/hex-val (char-at s 2))) + (gitea/hex-val (char-at s 3))))) + +(define gitea/pkt-max 65531) +(define gitea/pkt-fits? (fn (s) (<= (string-length s) gitea/pkt-max))) + +(define + gitea/pkt + (fn + (s) + (if + (gitea/pkt-fits? s) + (str (gitea/hex4 (+ (string-length s) 4)) s) + (error "gitea/pkt: payload exceeds pkt-line limit")))) + +(define gitea/pkt-flush "0000") + +; frame a list of line-lists, flush after each section +(define + gitea/pkt-render + (fn + (sections) + (join + "" + (map + (fn (lines) (str (join "" (map gitea/pkt lines)) gitea/pkt-flush)) + sections)))) + +; parse framed data into sections (lists of lines) split on flush pkts +(define + gitea/pkt-sections-loop + (fn + (data i cur sections) + (if + (>= i (string-length data)) + (reverse (if (empty? cur) sections (cons (reverse cur) sections))) + (let + ((n (gitea/hex4-parse (substr data i 4)))) + (if + (= n 0) + (gitea/pkt-sections-loop + data + (+ i 4) + (list) + (cons (reverse cur) sections)) + (gitea/pkt-sections-loop + data + (+ i n) + (cons (substr data (+ i 4) (- n 4)) cur) + sections)))))) + +(define + gitea/pkt-sections + (fn (data) (gitea/pkt-sections-loop data 0 (list) (list)))) + +; ── object closure ─────────────────────────────────────────────────── + +; cids an object references +(define + gitea/obj-refs + (fn + (obj) + (cond + ((git/commit? obj) + (cons (git/commit-tree obj) (git/commit-parents obj))) + ((git/tree? obj) + (map + (fn (n) (git/entry-cid (git/tree-entry-for obj n))) + (git/tree-names obj))) + ((git/tag? obj) (list (git/tag-target obj))) + (else (list))))) + +; walk from pending cids; returns {:seen {cid true} :missing (cids)} +(define + gitea/closure-walk + (fn + (grepo pending seen missing) + (if + (empty? pending) + {:seen seen :missing (reverse missing)} + (let + ((cid (first pending)) (more (rest pending))) + (if + (get seen cid) + (gitea/closure-walk grepo more seen missing) + (let + ((obj (git/read grepo cid))) + (if + (nil? obj) + (gitea/closure-walk grepo more seen (cons cid missing)) + (gitea/closure-walk + grepo + (concat (gitea/obj-refs obj) more) + (assoc seen cid true) + missing)))))))) + +(define + gitea/closure + (fn + (grepo cids) + (get (gitea/closure-walk grepo cids {} (list)) :seen))) + +(define + gitea/closure-list + (fn (grepo cids) (artdag/sort-strings (keys (gitea/closure grepo cids))))) + +(define + gitea/closure-complete? + (fn + (grepo cids) + (empty? + (get (gitea/closure-walk grepo cids {} (list)) :missing)))) + +; objects needed to bring someone with `haves` up to `wants` +(define + gitea/pack-cids + (fn + (grepo wants haves) + (let + ((have-set (gitea/closure grepo haves))) + (filter + (fn (c) (not (get have-set c))) + (gitea/closure-list grepo wants))))) + +; ── wire object encoding ───────────────────────────────────────────── + +(define + gitea/pack-line + (fn (grepo cid) (str cid " " (serialize (git/read grepo cid))))) + +; parse " " and verify the cid matches the bytes +(define + gitea/pack-line-parse + (fn + (line) + (let + ((sp (index-of line " "))) + (if + (< sp 0) + {:error "malformed"} + (let + ((cid (substr line 0 sp)) + (obj (first (sx-parse (substr line (+ sp 1)))))) + (if (= (git/cid obj) cid) {:obj obj :cid cid} {:error "cid-mismatch" :cid cid})))))) + +; verify + store every pack line; => {:stored n} | {:error ...} +(define + gitea/unpack! + (fn + (grepo lines) + (reduce + (fn + (acc line) + (if + (get acc :error) + acc + (let + ((p (gitea/pack-line-parse line))) + (if + (get p :error) + p + (begin (git/write grepo (get p :obj)) {:stored (+ (get acc :stored) 1)}))))) + {:stored 0} + lines))) + +; ── server: ref advertisement ──────────────────────────────────────── + +(define + gitea/shared-ref? + (fn (name) (or (starts-with? name "heads/") (starts-with? name "tags/")))) + +(define + gitea/wire-refs + (fn + (grepo) + (filter (fn (n) (gitea/shared-ref? n)) (git/ref-names grepo)))) + +(define + gitea/w-info-refs + (fn + (forge req) + (let + ((owner (dream-param req "owner")) (name (dream-param req "name"))) + (if + (not (gitea/w-readable? forge req owner name)) + (dream-not-found) + (let + ((grepo (gitea/repo-git forge owner name))) + (let + ((head-line (let ((target (git/head-target grepo))) (if (nil? target) (list) (list (str "@ " target))))) + (ref-lines + (map + (fn (n) (str (git/ref-get grepo n) " " n)) + (gitea/wire-refs grepo)))) + (dream-text + (gitea/pkt-render (list (concat head-line ref-lines)))))))))) + +; ── server: upload-pack (clone/fetch) ──────────────────────────────── + +(define + gitea/want-lines + (fn + (lines prefix) + (map + (fn (l) (substr l (string-length prefix))) + (filter (fn (l) (starts-with? l prefix)) lines)))) + +(define + gitea/w-upload-pack + (fn + (forge req) + (let + ((owner (dream-param req "owner")) (name (dream-param req "name"))) + (if + (not (gitea/w-readable? forge req owner name)) + (dream-not-found) + (let + ((grepo (gitea/repo-git forge owner name)) + (sections (gitea/pkt-sections (dream-body req)))) + (let + ((lines (if (empty? sections) (list) (first sections)))) + (let + ((wants (gitea/want-lines lines "want ")) + (haves (gitea/want-lines lines "have "))) + (dream-text + (gitea/pkt-render + (list + (map + (fn (c) (gitea/pack-line grepo c)) + (gitea/pack-cids grepo wants haves)))))))))))) + +; ── server: receive-pack (push) ────────────────────────────────────── + +(define gitea/zero-ref "-") + +; " " — old/new are cids or "-" +(define + gitea/cmd-parse + (fn + (line) + (let + ((a (index-of line " "))) + (let ((b (index-of (substr line (+ a 1)) " "))) {:name (substr line (+ a 1 b 1)) :new (substr line (+ a 1) b) :old (substr line 0 a)})))) + +; apply one ref command; => "ok " | "ng " +(define + gitea/apply-cmd! + (fn + (grepo cmd) + (let + ((old (get cmd :old)) (new (get cmd :new)) (name (get cmd :name))) + (cond + ((not (gitea/shared-ref? name)) (str "ng " name " invalid-ref")) + ((equal? new gitea/zero-ref) + (if + (= + (git/ref-get grepo name) + (if (equal? old gitea/zero-ref) nil old)) + (begin (git/ref-delete! grepo name) (str "ok " name)) + (str "ng " name " stale"))) + ((not (gitea/closure-complete? grepo (list new))) + (str "ng " name " missing-objects")) + ((and (not (equal? old gitea/zero-ref)) (starts-with? name "heads/") (not (git/is-ancestor? grepo old new))) + (str "ng " name " non-fast-forward")) + (else + (let + ((res (git/ref-cas! grepo name (if (equal? old gitea/zero-ref) nil old) new))) + (if + (and (dict? res) (get res :conflict)) + (str "ng " name " stale") + (str "ok " name)))))))) + +(define + gitea/w-receive-pack + (fn + (forge req) + (let + ((owner (dream-param req "owner")) (name (dream-param req "name"))) + (let + ((user (gitea/w-user forge req))) + (cond + ((not (gitea/can? forge user "read" owner name)) + (dream-not-found)) + ((nil? user) (gitea/w-unauthorized)) + ((not (gitea/can? forge user "write" owner name)) + (gitea/w-forbidden)) + (else + (let + ((grepo (gitea/repo-git forge owner name)) + (sections (gitea/pkt-sections (dream-body req)))) + (let + ((cmds (if (empty? sections) (list) (first sections))) + (objs + (if + (< (len sections) 2) + (list) + (nth sections 1)))) + (let + ((unpack (gitea/unpack! grepo objs))) + (if + (get unpack :error) + (dream-text + (gitea/pkt-render + (list (list (str "unpack " (get unpack :error)))))) + (dream-text + (gitea/pkt-render + (list + (cons + "unpack ok" + (map + (fn + (c) + (gitea/apply-cmd! grepo (gitea/cmd-parse c))) + cmds))))))))))))))) + +; ── routes ─────────────────────────────────────────────────────────── + +(define + gitea/wire-routes + (fn + (forge) + (list + (dream-get + "/:owner/:name/info/refs" + (fn (req) (gitea/w-info-refs forge req))) + (dream-post + "/:owner/:name/git-upload-pack" + (fn (req) (gitea/w-upload-pack forge req))) + (dream-post + "/:owner/:name/git-receive-pack" + (fn (req) (gitea/w-receive-pack forge req)))))) + +(set! gitea/route-packs (append gitea/route-packs (list gitea/wire-routes))) + +; back-compat aliases from before the route-pack registry +(define gitea/forge-routes gitea/all-routes) +(define gitea/forge-app gitea/app) + +; ── client ─────────────────────────────────────────────────────────── +; A remote is any dream app fn plus repo coordinates and a token — the +; same code drives an in-memory forge or (later) a real HTTP transport. + +(define gitea/remote (fn (app owner name token) {:name name :token token :owner owner :app app})) + +(define + gitea/remote-call + (fn + (remote method suffix body) + ((get remote :app) + (dream-request + method + (str "/" (get remote :owner) "/" (get remote :name) suffix) + (if (nil? (get remote :token)) {} {:authorization (str "Bearer " (get remote :token))}) + body)))) + +; => {:head "heads/..."|nil :refs {name cid}} | nil when unreachable +(define + gitea/ls-remote + (fn + (remote) + (let + ((resp (gitea/remote-call remote "GET" "/info/refs" ""))) + (if + (not (= (dream-status resp) 200)) + nil + (let + ((lines (let ((s (gitea/pkt-sections (dream-resp-body resp)))) (if (empty? s) (list) (first s))))) + (reduce + (fn + (acc l) + (let + ((sp (index-of l " "))) + (if + (starts-with? l "@ ") + (assoc acc :head (substr l 2)) + (assoc + acc + :refs (assoc + (get acc :refs) + (substr l (+ sp 1)) + (substr l 0 sp)))))) + {:refs {} :head nil} + lines)))))) + +; fetch the closure of `wants` (minus `haves`) into grepo +(define + gitea/fetch-pack! + (fn + (remote grepo wants haves) + (let + ((resp (gitea/remote-call remote "POST" "/git-upload-pack" (gitea/pkt-render (list (concat (map (fn (c) (str "want " c)) wants) (map (fn (c) (str "have " c)) haves))))))) + (if + (not (= (dream-status resp) 200)) + {:error (dream-status resp)} + (let + ((s (gitea/pkt-sections (dream-resp-body resp)))) + (gitea/unpack! grepo (if (empty? s) (list) (first s)))))))) + +; mirror-style fetch: pull missing objects, retarget local heads/tags +; => {:refs ... :stored n} | {:error status} +(define + gitea/fetch! + (fn + (remote grepo) + (let + ((ls (gitea/ls-remote remote))) + (if + (nil? ls) + {:error 404} + (let + ((refs (get ls :refs))) + (let + ((wants (filter (fn (c) (not (git/has? grepo c))) (map (fn (n) (get refs n)) (keys refs)))) + (haves + (filter + (fn (c) (not (nil? c))) + (map + (fn (b) (git/branch-get grepo b)) + (git/branches grepo))))) + (let + ((res (if (empty? wants) {:stored 0} (gitea/fetch-pack! remote grepo wants haves)))) + (if + (get res :error) + res + (begin + (for-each + (fn (n) (git/ref-set! grepo n (get refs n))) + (keys refs)) + {:refs refs :stored (get res :stored)}))))))))) + +; clone a remote into this forge as owner/name; the repo is removed +; again if the remote turns out to be unreachable +(define + gitea/clone! + (fn + (forge owner name remote opts) + (let + ((rec (gitea/repo-create! forge owner name (or opts {})))) + (if + (or (get rec :error) (get rec :conflict)) + rec + (let + ((grepo (gitea/repo-git forge owner name))) + (let + ((res (gitea/fetch! remote grepo))) + (if + (get res :error) + (begin (gitea/repo-delete! forge owner name) res) + (let + ((head (get (gitea/ls-remote remote) :head))) + (begin + (if + (and head (starts-with? head "heads/")) + (let + ((branch (substr head (string-length "heads/")))) + (begin + (git/head-set! grepo branch) + (gitea/repo-update! + forge + owner + name + (fn (r) (assoc r :default-branch branch))) + nil)) + nil) + rec))))))))) + +; push one ref; => {:ok true} | {:ng reason} | {:error status} +(define + gitea/push-cmd! + (fn + (remote grepo refname new) + (let + ((ls (gitea/ls-remote remote))) + (if + (nil? ls) + {:error 404} + (let + ((old (or (get (get ls :refs) refname) gitea/zero-ref))) + (let + ((pack (if (equal? new gitea/zero-ref) (list) (gitea/pack-cids grepo (list new) (if (equal? old gitea/zero-ref) (list) (list old)))))) + (let + ((resp (gitea/remote-call remote "POST" "/git-receive-pack" (gitea/pkt-render (list (list (str old " " new " " refname)) (map (fn (c) (gitea/pack-line grepo c)) pack)))))) + (if + (not (= (dream-status resp) 200)) + {:error (dream-status resp)} + (let + ((lines (let ((s (gitea/pkt-sections (dream-resp-body resp)))) (if (empty? s) (list) (first s))))) + (let + ((status (first (filter (fn (l) (or (starts-with? l "ok ") (starts-with? l "ng "))) lines)))) + (cond + ((nil? status) {:error "no-status"}) + ((starts-with? status "ok ") {:ok true}) + (else {:ng (substr status (+ (index-of (substr status 3) " ") 4))})))))))))))) + +(define + gitea/push! + (fn + (remote grepo refname) + (let + ((new (git/ref-get grepo refname))) + (if (nil? new) {:error "no-such-local-ref"} (gitea/push-cmd! remote grepo refname new))))) + +(define + gitea/push-delete! + (fn + (remote grepo refname) + (gitea/push-cmd! remote grepo refname gitea/zero-ref)))