kb: close the directive bypass, and package both tools as skills
Review on PR #68 found two real holes, both reproduced by injection before fixing and both now regression-tested: - A DIRECTIVE is callable, so the callable check let one through -- and the candidate is validated by CONSULTING it, so a delta of `:- halt(0).` exited the check with success before kb_consistent ran. The gate passed by never running, and the directive landed in kb.pl. Directives and queries are now refused by shape. - Keys were checked only against the EXISTING file, so two clauses sharing a previously-unused key clashed with nothing and the merge dropped the first -- add discarding part of its own payload. Visible in the tool's own output ("2 in delta" against one clause added) and nothing compared those numbers. Also from the review: nothing ran kb-test.sh. A suite that gates the only writer of kb.pl but is invoked by no workflow is doctrine(an_advisory_gate_is_not_a_gate) in the PR that adds it. Both suites now run in the kb job. AGENTS.md now leads with the rule instead of describing the retired procedure first -- the review read against the earlier head, but it was half right at the later one too: a skimming reader followed the batching paragraph. Both tools are packaged as skills, because the failure is not that the scripts are missing, it is that agents do not know they exist and write their own. Three hand-rolled PR watchers in one session all reported green while wrong, which is what scripts/pr-watch and its eight fixture cases exist to stop. One of those cases -- a head that moves mid-wait -- was untestable until a subshell bug in the fixture seam was fixed: fetch ran inside "$(...)", so its counter never advanced and every poll re-read the first fixture. Co-Authored-By: Claude Opus 5 (1M context) <noreply@anthropic.com> Claude-Session: https://claude.ai/code/session_01FC2jVn8Au7E9JPkw6bwXXH
This commit is contained in:
Edward Langley
+40
-4
@@ -23,6 +23,7 @@ run(remove, KbFile, DeltaFile, OutFile) :-
|
||||
terms_of(KbFile, Old),
|
||||
terms_of(DeltaFile, Doomed),
|
||||
check_callable(Doomed),
|
||||
check_self_consistent(Doomed),
|
||||
absent(Old, Doomed, Missing),
|
||||
( Missing == []
|
||||
-> true
|
||||
@@ -40,6 +41,7 @@ run(Mode, KbFile, DeltaFile, OutFile) :-
|
||||
terms_of(KbFile, Old),
|
||||
terms_of(DeltaFile, New),
|
||||
check_callable(New),
|
||||
check_self_consistent(New),
|
||||
conflicts(Old, New, Clashes),
|
||||
gate(Mode, Clashes),
|
||||
foldl_merge(New, Mode, Old, Merged),
|
||||
@@ -53,13 +55,22 @@ run(Mode, KbFile, DeltaFile, OutFile) :-
|
||||
% Nothing downstream objected -- kb_consistent has no opinion about stray terms.
|
||||
check_callable([]).
|
||||
check_callable([T|Ts]) :-
|
||||
clause_head(T, H),
|
||||
( callable(H)
|
||||
-> check_callable(Ts)
|
||||
; format("kb-merge: REFUSED -- not a clause: ~q~n", [T]),
|
||||
( bad_shape(T, Why)
|
||||
-> format("kb-merge: REFUSED -- ~w: ~q~n", [Why, T]),
|
||||
halt(2)
|
||||
; check_callable(Ts)
|
||||
).
|
||||
|
||||
% A DIRECTIVE is callable, so a callable test alone lets one through -- and the
|
||||
% candidate is validated by consulting it, so `:- halt(0).` exits the check
|
||||
% with success before kb_consistent runs and the gate passes by never running.
|
||||
bad_shape(T, 'a directive, which would run when the result is checked') :-
|
||||
nonvar(T), T = (:- _), !.
|
||||
bad_shape(T, 'a query') :-
|
||||
nonvar(T), T = (?- _), !.
|
||||
bad_shape(T, 'not a clause') :-
|
||||
clause_head(T, H), \+ callable(H).
|
||||
|
||||
clause_head((H :- _), H) :- !.
|
||||
clause_head(H, H).
|
||||
|
||||
@@ -79,6 +90,31 @@ head_key(H, K) :-
|
||||
clause_pred((H :- _), F/A) :- !, functor(H, F, A).
|
||||
clause_pred(H, F/A) :- functor(H, F, A).
|
||||
|
||||
% Keys were only checked against the EXISTING file, so two clauses sharing a
|
||||
% previously-unused key clashed with nothing and the merge silently dropped the
|
||||
% first -- add discarding part of its own payload, visible only as a delta count
|
||||
% that did not match the clauses added.
|
||||
check_self_consistent(New) :-
|
||||
findall(K, ( member(T, New), clause_key(T, K) ), Ks),
|
||||
msort(Ks, Sorted),
|
||||
adjacent_dups(Sorted, Dups0),
|
||||
sort(Dups0, Dups),
|
||||
( Dups == []
|
||||
-> true
|
||||
; format("kb-merge: REFUSED -- the delta names one key twice:~n", []),
|
||||
forall(member(K, Dups), format(" ~q~n", [K])),
|
||||
halt(2)
|
||||
).
|
||||
|
||||
adjacent_dups([], []).
|
||||
adjacent_dups([_], []).
|
||||
adjacent_dups([A, B|T], Out) :-
|
||||
( A == B
|
||||
-> Out = [A|Rest]
|
||||
; Out = Rest
|
||||
),
|
||||
adjacent_dups([B|T], Rest).
|
||||
|
||||
conflicts(Old, New, Clashes) :-
|
||||
findall(K,
|
||||
( member(T, New), clause_key(T, K),
|
||||
|
||||
@@ -112,6 +112,37 @@ else
|
||||
bad "rm refused an absent key but MODIFIED the kb"
|
||||
fi
|
||||
|
||||
# 4d. A DIRECTIVE is callable, so a callable test alone lets it through -- and
|
||||
# the candidate is validated by CONSULTING it, so `:- halt(0).` exits the
|
||||
# check with success before kb_consistent runs. The gate passes by never
|
||||
# running. Found by review on PR #68; demonstrated before it was fixed.
|
||||
fresh
|
||||
printf ':- halt(0).\n' > "$work/directive.pl"
|
||||
if kb add "$work/directive.pl" >/dev/null 2>&1; then
|
||||
bad "add accepted a directive that disables its own gate"
|
||||
elif unchanged; then
|
||||
ok "add refuses a directive and leaves the kb unchanged"
|
||||
else
|
||||
bad "add refused a directive but MODIFIED the kb"
|
||||
fi
|
||||
|
||||
# 4e. Keys were checked only against the EXISTING file, so two clauses sharing a
|
||||
# previously-unused key clashed with nothing and the merge dropped the first
|
||||
# -- add discarding part of its own payload, visible only as a delta count
|
||||
# that did not match the clauses added.
|
||||
fresh
|
||||
cat > "$work/selfdup.pl" <<'EOD'
|
||||
doctrine(a_name_used_twice_in_one_delta,'first').
|
||||
doctrine(a_name_used_twice_in_one_delta,'second').
|
||||
EOD
|
||||
if kb add "$work/selfdup.pl" >/dev/null 2>&1; then
|
||||
bad "add accepted a delta naming one key twice"
|
||||
elif unchanged; then
|
||||
ok "add refuses a delta that names one key twice"
|
||||
else
|
||||
bad "add refused a self-duplicate but MODIFIED the kb"
|
||||
fi
|
||||
|
||||
echo "kb-test: the happy paths"
|
||||
|
||||
# 5. A genuinely new clause lands, and the count moves by exactly one.
|
||||
|
||||
Executable
+114
@@ -0,0 +1,114 @@
|
||||
#!/usr/bin/env bash
|
||||
# Waits for a PR's checks to finish and says what happened. Every rule in here
|
||||
# is one this repo got wrong first; see context/code/pr-watch.md.
|
||||
set -euo pipefail
|
||||
|
||||
usage() {
|
||||
cat >&2 <<'EOF'
|
||||
usage: pr-watch <pr-number> [--expect <sha>] [--timeout <sec>] [--interval <sec>]
|
||||
|
||||
--expect <sha> fail if the PR head is not this (prefix ok) at any poll
|
||||
--timeout <sec> give up after this long (default 1800)
|
||||
--interval <sec> seconds between polls (default 20)
|
||||
|
||||
exit 0 every check COMPLETED and none failed
|
||||
exit 1 a check failed, or the PR is not mergeable
|
||||
exit 2 the head moved during the wait, or is not --expect
|
||||
exit 3 timed out with checks still running
|
||||
exit 4 usage or environment error
|
||||
EOF
|
||||
exit 4
|
||||
}
|
||||
|
||||
PR=""; EXPECT=""; TIMEOUT=1800; INTERVAL=20
|
||||
while [ $# -gt 0 ]; do
|
||||
case "$1" in
|
||||
--expect) EXPECT="${2:-}"; shift 2 ;;
|
||||
--timeout) TIMEOUT="${2:-}"; shift 2 ;;
|
||||
--interval) INTERVAL="${2:-}"; shift 2 ;;
|
||||
-h|--help) usage ;;
|
||||
*) [ -z "$PR" ] || usage; PR="$1"; shift ;;
|
||||
esac
|
||||
done
|
||||
[ -n "$PR" ] || usage
|
||||
|
||||
# `gh` is shell-aliased to a different tool in this repo's shells, so the name
|
||||
# is never trusted: a real gh is located explicitly.
|
||||
fetch() {
|
||||
if [ -n "${PR_WATCH_FIXTURE_DIR:-}" ]; then
|
||||
# The counter lives on disk because fetch is called as "$(fetch)", and a
|
||||
# command substitution is a SUBSHELL -- a variable incremented in it is
|
||||
# lost, so every poll re-read the first fixture and no test could ever
|
||||
# reach the second one.
|
||||
local c="$PR_WATCH_FIXTURE_DIR/.poll"
|
||||
local n=$(( $(cat "$c" 2>/dev/null || echo 0) + 1 ))
|
||||
echo "$n" > "$c"
|
||||
local f="$PR_WATCH_FIXTURE_DIR/$n.json"
|
||||
[ -f "$f" ] || f="$PR_WATCH_FIXTURE_DIR/last.json"
|
||||
cat "$f"
|
||||
return
|
||||
fi
|
||||
if command -v gh >/dev/null 2>&1 && gh --version 2>/dev/null | grep -q '^gh version'; then
|
||||
gh pr view "$PR" --json headRefOid,mergeable,mergeStateStatus,statusCheckRollup
|
||||
else
|
||||
nix shell nixpkgs#gh --command gh pr view "$PR" \
|
||||
--json headRefOid,mergeable,mergeStateStatus,statusCheckRollup
|
||||
fi
|
||||
}
|
||||
|
||||
jqf() { jq -r "$1"; }
|
||||
|
||||
started=$(date +%s)
|
||||
pinned=""
|
||||
|
||||
while :; do
|
||||
json="$(fetch)" || { echo "pr-watch: cannot read PR $PR" >&2; exit 4; }
|
||||
|
||||
head="$(printf '%s' "$json" | jqf '.headRefOid')"
|
||||
|
||||
# A verdict about a tree that no longer exists reads as a pass. This is not
|
||||
# hypothetical here: PR #67 was merged at a head that predated its fix.
|
||||
if [ -n "$EXPECT" ] && [ "${head#"$EXPECT"}" = "$head" ]; then
|
||||
echo "pr-watch: head is $head, expected $EXPECT*" >&2
|
||||
exit 2
|
||||
fi
|
||||
if [ -z "$pinned" ]; then
|
||||
pinned="$head"
|
||||
elif [ "$head" != "$pinned" ]; then
|
||||
echo "pr-watch: head moved $pinned -> $head during the wait" >&2
|
||||
exit 2
|
||||
fi
|
||||
|
||||
# total>0 AND nothing still running. "0 pending" alone reads identically for
|
||||
# "all finished" and "none registered yet", which is how this exited instantly
|
||||
# on a fresh push. And `conclusion` is a STRING, empty while running, never
|
||||
# null -- so a null test matches nothing and every check looks finished.
|
||||
total="$(printf '%s' "$json" | jqf '[.statusCheckRollup[]?] | length')"
|
||||
running="$(printf '%s' "$json" | jqf '[.statusCheckRollup[]? | select(.status != "COMPLETED")] | length')"
|
||||
|
||||
if [ "$total" -gt 0 ] && [ "$running" -eq 0 ]; then
|
||||
break
|
||||
fi
|
||||
|
||||
now=$(date +%s)
|
||||
if [ $((now - started)) -ge "$TIMEOUT" ]; then
|
||||
echo "pr-watch: timed out after ${TIMEOUT}s with $running of $total still running" >&2
|
||||
exit 3
|
||||
fi
|
||||
sleep "$INTERVAL"
|
||||
done
|
||||
|
||||
printf '%s' "$json" | jqf '.statusCheckRollup[]? | select(.conclusion != "SKIPPED") | " \(.conclusion) \(.name)"'
|
||||
|
||||
failed="$(printf '%s' "$json" | jqf \
|
||||
'[.statusCheckRollup[]? | select(.conclusion != "SUCCESS" and .conclusion != "SKIPPED" and .conclusion != "NEUTRAL")] | length')"
|
||||
mergeable="$(printf '%s' "$json" | jqf '.mergeable')"
|
||||
state="$(printf '%s' "$json" | jqf '.mergeStateStatus')"
|
||||
|
||||
echo "pr-watch: head=$head $mergeable/$state $total checks, $failed failed"
|
||||
|
||||
[ "$failed" -eq 0 ] || exit 1
|
||||
# UNSTABLE means a non-required check is unhappy; it is not a merge blocker on
|
||||
# its own, so only an outright non-mergeable state fails here.
|
||||
[ "$mergeable" != "CONFLICTING" ] || exit 1
|
||||
exit 0
|
||||
Executable
+77
@@ -0,0 +1,77 @@
|
||||
#!/usr/bin/env bash
|
||||
# check_the_checker for scripts/pr-watch. Every case is a state this repo
|
||||
# actually hit; three of them are watchers that exited green while wrong.
|
||||
set -uo pipefail
|
||||
|
||||
here="$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)"
|
||||
WATCH="$here/pr-watch"
|
||||
work="$(mktemp -d)"
|
||||
trap 'rm -rf "$work"' EXIT
|
||||
|
||||
pass=0; fail=0
|
||||
ok() { printf ' ok %s\n' "$1"; pass=$((pass+1)); }
|
||||
bad() { printf ' FAIL %s (exit %s, wanted %s)\n' "$1" "$2" "$3"; fail=$((fail+1)); }
|
||||
|
||||
# $1 name, $2 expected exit, $3 fixture dir, rest: extra args
|
||||
run_case() {
|
||||
local name="$1" want="$2" dir="$3"; shift 3
|
||||
PR_WATCH_FIXTURE_DIR="$dir" "$WATCH" 1 --interval 0 --timeout 1 "$@" >/dev/null 2>&1
|
||||
local got=$?
|
||||
[ "$got" = "$want" ] && ok "$name" || bad "$name" "$got" "$want"
|
||||
}
|
||||
|
||||
mk() { mkdir -p "$1"; cat > "$1/$2"; }
|
||||
|
||||
# The state a fresh push is in: the PR exists, no check has registered yet.
|
||||
# A watcher keyed on "nothing pending" calls this finished and green.
|
||||
mk "$work/none" last.json <<'EOF'
|
||||
{"headRefOid":"aaaaaaaaaaaa","mergeable":"MERGEABLE","mergeStateStatus":"CLEAN","statusCheckRollup":[]}
|
||||
EOF
|
||||
run_case "no checks registered yet is not success" 3 "$work/none"
|
||||
|
||||
# conclusion is a STRING, empty while running -- never null. A null test
|
||||
# matches nothing, so every check looks finished.
|
||||
mk "$work/running" last.json <<'EOF'
|
||||
{"headRefOid":"aaaaaaaaaaaa","mergeable":"MERGEABLE","mergeStateStatus":"UNSTABLE","statusCheckRollup":[
|
||||
{"name":"build","status":"IN_PROGRESS","conclusion":""},
|
||||
{"name":"test","status":"COMPLETED","conclusion":"SUCCESS"}]}
|
||||
EOF
|
||||
run_case "a running check with an empty conclusion is not finished" 3 "$work/running"
|
||||
|
||||
mk "$work/green" last.json <<'EOF'
|
||||
{"headRefOid":"aaaaaaaaaaaa","mergeable":"MERGEABLE","mergeStateStatus":"CLEAN","statusCheckRollup":[
|
||||
{"name":"build","status":"COMPLETED","conclusion":"SUCCESS"},
|
||||
{"name":"skipped","status":"COMPLETED","conclusion":"SKIPPED"}]}
|
||||
EOF
|
||||
run_case "all completed and green" 0 "$work/green"
|
||||
|
||||
mk "$work/red" last.json <<'EOF'
|
||||
{"headRefOid":"aaaaaaaaaaaa","mergeable":"MERGEABLE","mergeStateStatus":"UNSTABLE","statusCheckRollup":[
|
||||
{"name":"build","status":"COMPLETED","conclusion":"FAILURE"}]}
|
||||
EOF
|
||||
run_case "a failed check fails" 1 "$work/red"
|
||||
|
||||
mk "$work/conflict" last.json <<'EOF'
|
||||
{"headRefOid":"aaaaaaaaaaaa","mergeable":"CONFLICTING","mergeStateStatus":"DIRTY","statusCheckRollup":[
|
||||
{"name":"build","status":"COMPLETED","conclusion":"SUCCESS"}]}
|
||||
EOF
|
||||
run_case "green checks on a conflicting PR still fail" 1 "$work/conflict"
|
||||
|
||||
# The one that cost a real fix: a verdict about a tree that no longer exists
|
||||
# reads as a pass. PR #67 merged at a head that predated its correction.
|
||||
mkdir -p "$work/moved"
|
||||
cat > "$work/moved/1.json" <<'EOF'
|
||||
{"headRefOid":"aaaaaaaaaaaa","mergeable":"MERGEABLE","mergeStateStatus":"UNSTABLE","statusCheckRollup":[
|
||||
{"name":"build","status":"IN_PROGRESS","conclusion":""}]}
|
||||
EOF
|
||||
cat > "$work/moved/last.json" <<'EOF'
|
||||
{"headRefOid":"bbbbbbbbbbbb","mergeable":"MERGEABLE","mergeStateStatus":"CLEAN","statusCheckRollup":[
|
||||
{"name":"build","status":"COMPLETED","conclusion":"SUCCESS"}]}
|
||||
EOF
|
||||
run_case "a head that moves mid-wait is not a pass" 2 "$work/moved" --timeout 60
|
||||
|
||||
run_case "--expect refuses a different head" 2 "$work/green" --expect bbbbbbbb
|
||||
run_case "--expect accepts a prefix of the head" 0 "$work/green" --expect aaaa
|
||||
|
||||
printf '\npr-watch-test: %d passed, %d failed\n' "$pass" "$fail"
|
||||
[ "$fail" -eq 0 ]
|
||||
Reference in New Issue
Block a user