scripts/grant-differential-probe.sgl

1;;; Differential probe for the (sigil system grant) migration.

2;;;

3;;; Prints one line per observable decision. Run once against the

4;;; pre-migration module and once against the migrated one; the two

5;;; transcripts must be byte-identical. Every line is a decision the

6;;; PUBLIC API produced -- nothing here reaches inside the module.

7(import (sigil io)

8 (sigil process)

9 (sigil fs)

10 (sigil path)

11 (sigil string)

12 (sigil system grant))

14(define ROOT (getenv "GRANT_DIFF_ROOT"))

16(define (outcome thunk)

17 (guard (e (#t "RAISED"))

18 (let ((v (thunk))) (if v "#t" "#f"))))

20;; --- the grant configurations under test -------------------------

21;; Each is a list of specs handed to grant-add! in order. Ordering

22;; matters for the exec-full-absorbs-allowlist case, so both orders

23;; are present.

24(define configs

25 (list

26 (cons "empty" '())

27 (cons "pty" (list "pty:on"))

28 (cons "exec-allow" (list "exec:allowlist:ls,git"))

29 (cons "exec-full" (list "exec:full"))

30 (cons "full-then-al" (list "exec:full" "exec:allowlist:ls"))

31 (cons "al-then-full" (list "exec:allowlist:ls" "exec:full"))

32 (cons "two-allow" (list "exec:allowlist:ls" "exec:allowlist:git"))

33 ;; Configuration artifacts. The corpus MISSED these on the first

34 ;; pass and the differential passed 460 of 460 while a real

35 ;; divergence sat in exactly this shape: a trailing comma turned

36 ;; `git` from permitted into denied. A corpus that omits the

37 ;; awkward spelling of a real config is a corpus that agrees for

38 ;; the wrong reason.

39 (cons "trailing-comma" (list "exec:allowlist:git,"))

40 (cons "leading-comma" (list "exec:allowlist:,git"))

41 (cons "double-comma" (list "exec:allowlist:git,,ls"))

42 (cons "only-commas" (list "exec:allowlist:,"))

43 (cons "comma-in-cmd" (list "exec:allowlist:a,b"))

44 (cons "fs-ro-root" (list (string-append "fs:ro:" ROOT)))

45 (cons "fs-rw-root" (list (string-append "fs:rw:" ROOT)))

46 (cons "fs-rw-allow" (list (string-append "fs:rw:" (path-join ROOT "allow"))))

47 (cons "fs-both" (list (string-append "fs:ro:" ROOT)

48 (string-append "fs:rw:" (path-join ROOT "allow"))))

49 (cons "fs-nested" (list (string-append "fs:rw:" ROOT)

50 (string-append "fs:ro:" (path-join ROOT "allow"))))

51 (cons "comma-dir" (list (string-append "fs:rw:" (path-join ROOT "a,b"))))

52 (cons "bad-relative" (list "fs:rw:relative/path"))

53 (cons "bad-missing" (list (string-append "fs:rw:" (path-join ROOT "no-such-dir"))))

54 (cons "bad-mode" (list "fs:xx:/tmp"))

55 (cons "bad-spec" (list "nonsense"))

56 (cons "bad-kind-net" (list "net:connect:*"))

57 (cons "bad-kind-eval" (list "eval:on"))))

59;; --- the operations checked against each ------------------------

60(define (ops)

61 (list

62 (list 'pty #t)

63 (list 'exec "ls")

64 (list 'exec "git")

65 (list 'exec "rm")

66 (list 'exec "/tmp/evil/ls") ; basename must NOT match

67 (list 'exec "") ; empty argv[0]

68 (list 'exec "we,ird") ; a comma: must DENY, never raise

69 (list 'exec "we:ird") ; a colon: must DENY, never raise

70 (list 'fs-read ROOT)

71 (list 'fs-write ROOT)

72 (list 'fs-read (path-join ROOT "allow"))

73 (list 'fs-write (path-join ROOT "allow" "x"))

74 (list 'fs-read (path-join ROOT "allowed" "x")) ; sibling prefix, must NOT leak

75 (list 'fs-write (path-join ROOT "allowed" "x"))

76 (list 'fs-read (path-join ROOT "a,b" "f")) ; comma-bearing real dir

77 (list 'fs-write (path-join ROOT "a,b" "f"))

78 (list 'fs-read (path-join ROOT "link-out")) ; symlink escaping the root

79 (list 'fs-write (path-join ROOT "link-out" "x"))

80 (list 'fs-read "/etc/hosts")

81 (list 'fs-write "/etc/passwd")

82 (list 'fs-read (path-join ROOT "nope")) ; nonexistent read

83 (list 'fs-write (path-join ROOT "nope")) ; nonexistent write (parent exists)

84 (list 'unknown-op "x")))

86(define decisions 0)

88(for-each

89 (lambda (cfg)

90 (let ((name (car cfg))

91 (specs (cdr cfg)))

92 ;; grant-add! outcomes are observable behaviour too.

93 (let ((g (make-grants principal: "diff")))

94 (for-each

95 (lambda (s)

96 (println "ADD|~a|~a" name (outcome (lambda () (grant-add! g s) #t))))

97 specs)

98 (for-each

99 (lambda (o)

100 (set! decisions (+ decisions 1))

101 (println "CHK|~a|~a|~s|~a" name (car o) (cadr o)

102 (outcome (lambda () (grant-check g (car o) (cadr o))))))

103 (ops))

104 ;; the audit log must keep counting the same way

105 (println "LOG|~a|~a" name (length (grant-decisions g))))))

106 configs)

107

108;; The allow-all posture is constructed differently and gets its own pass.

109(let ((g (grant-allow-all principal: "diff")))

110 (for-each

111 (lambda (o)

112 (set! decisions (+ decisions 1))

113 (println "CHK|allow-all|~a|~s|~a" (car o) (cadr o)

114 (outcome (lambda () (grant-check g (car o) (cadr o))))))

115 (ops)))

116

117(println "GRANTS-PRED|~a|~a"

118 (outcome (lambda () (grants? (make-grants))))

119 (outcome (lambda () (grants? (vector 'nope)))))

120(println "PRINCIPAL|~a" (grants-principal (make-grants principal: "who")))

121(println "DECISIONS ~a" decisions)