tools/f4a_graph_probe.sgl

1;;; F4a graph probe -- a FACT EMITTER, deliberately not a judge.

2;;;

3;;; Every subcommand prints machine-readable lines and exits 0 unless the

4;;; product raised. It never decides that an arm passed. That split is the

5;;; point: if this file computed verdicts, a sabotage planted in `(folio graph)`

6;;; could make the probe report PASS using the very code under test, and the

7;;; gate would be asserting the product's opinion of itself. `test/gate-f4a.sh`

8;;; owns every comparison.

9;;;

10;;; A raise is NOT swallowed. A probe that guards its own body turns a broken

11;;; product into an empty result set, and an empty result set is what a clean

12;;; corpus also looks like.

13

14(import (sigil core) (sigil string) (sigil list) (sigil fs) (sigil path)

15 (sigil sqlite)

16 (folio store) (folio graph) (folio doc model) (folio doc inspect))

17

18;; `(sigil sqlite)` is imported for the DAMAGE commands only. Arm 7 needs a

19;; file that is a perfectly valid SQLite database and simply is not OUR schema

20;; -- the case a "can we open it" check passes and a "does it answer correctly"

21;; check does not. There is no sqlite3 CLI on this host, so the damage is done

22;; here, through the same library, but deliberately OUTSIDE the product's API:

23;; the recovery path must meet the damage as an accomplished fact, not as

24;; something the product did to itself.

25

26(define (args-after-script rest)

27 (cond

28 ((null? rest) '())

29 ((string-ends-with? (car rest) ".sgl") (cdr rest))

30 (else (args-after-script (cdr rest)))))

31

32(define (emit . parts)

33 (display (string-join (map (lambda (p) (format "~a" p)) parts) "\t"))

34 (newline))

35

36(define (open-graph root ws provider)

37 (make-folio-graph (make-folio-store root) ws provider))

38

39(define (rows->lines tag rows keys)

40 (for-each

41 (lambda (r)

42 (apply emit tag

43 (map (lambda (k)

44 (let ((hit (assq k r)))

45 (if hit (format "~a" (cdr hit)) "")))

46 keys)))

47 rows))

48

49(define (main-probe args)

50 (if (null? args)

51 (begin (display "usage: f4a_graph_probe <cmd> <root> <ws> <provider> [...]\n") 2)

52 (let* ((cmd (car args))

53 (rest (cdr args)))

54 (cond

55 ;; `vocabulary` needs no workspace: it reports what the MODEL says the

56 ;; built-in edge kinds are, plus the frozen vocabulary names, so the

57 ;; gate can check this module's one name-level restatement against the

58 ;; artifact rather than against a list in a comment.

59 ((equal? cmd "vocabulary")

60 (for-each (lambda (k) (emit "EDGE_KIND" k)) (graph-built-in-edge-kinds))

61 (for-each (lambda (n) (emit "VOCAB_NAME" n)) (folio-vocabulary-names))

62 0)

63 ;; The damage commands do NOT go through `make-folio-graph`; opening

64 ;; through the product would recover the database before it could be

65 ;; broken.

66 ((equal? cmd "damage-foreign")

67 (let* ((p (path-join (car rest) ".folio-graph.db"))

68 (db (begin (when (file-exists? p) (delete-file p)) (sqlite-open p))))

69 (unless db (error "damage-foreign: could not create the decoy database"))

70 (sqlite-exec db "CREATE TABLE somebody_elses (id INTEGER PRIMARY KEY, v TEXT)")

71 (sqlite-exec db "INSERT INTO somebody_elses (v) VALUES ('not folio')")

72 (sqlite-close db)

73 (emit "DAMAGED" "foreign-schema" p)

74 0))

75 ((equal? cmd "damage-version")

76 (let* ((p (path-join (car rest) ".folio-graph.db"))

77 (db (sqlite-open p)))

78 (unless db (error "damage-version: could not open the database"))

79 (sqlite-exec db "UPDATE graph_meta SET value = '999' WHERE key = 'schema_version'")

80 (sqlite-close db)

81 (emit "DAMAGED" "schema-version-999" p)

82 0))

83 ((equal? cmd "damage-drop-table")

84 (let* ((p (path-join (car rest) ".folio-graph.db"))

85 (db (sqlite-open p)))

86 (unless db (error "damage-drop-table: could not open the database"))

87 (sqlite-exec db "DROP TABLE edges")

88 (sqlite-close db)

89 (emit "DAMAGED" "edges-table-dropped" p)

90 0))

91 ((null? rest)

92 (display "usage: f4a_graph_probe <cmd> <root> <ws> <provider> [...]\n") 2)

93 (else

94 (let* ((root (car rest))

95 (ws (cadr rest))

96 (provider (caddr rest))

97 (extra (cdddr rest))

98 (g (open-graph root ws provider)))

99 (emit "OPEN" root ws provider (graph-open-state g))

100 (cond

101 ((equal? cmd "rebuild")

102 (emit "DOCS" (graph-rebuild! g)) 0)

103 ((equal? cmd "index")

104 (emit "DOC_UID" (graph-index-document! g (car extra))) 0)

105 ((equal? cmd "remove")

106 (graph-remove-document! g (car extra))

107 (emit "REMOVED" (car extra)) 0)

108 ((equal? cmd "remount")

109 (graph-remount! g)

110 (emit "REMOUNTED" root provider) 0)

111 ((equal? cmd "dump")

112 (for-each (lambda (l) (emit "R" l)) (graph-relation-dump g))

113 (emit "DUMP_LINES" (length (graph-relation-dump g)))

114 0)

115 ((equal? cmd "sources")

116 (let ((ss (graph-source-files g)))

117 (for-each (lambda (s)

118 (emit "SOURCE" (car s) (cadr s) (caddr s)

119 (if (cadddr s) "contested" "sole")))

120 ss)

121 (emit "SOURCE_COUNT" (length ss)))

122 0)

123 ((equal? cmd "documents")

124 (rows->lines "DOCUMENT" (graph-documents g)

125 '(doc_uid slug format path revision parsed contested))

126 (emit "DOCUMENT_COUNT" (length (graph-documents g)))

127 0)

128 ((equal? cmd "nodes")

129 (rows->lines "NODE" (graph-nodes g)

130 '(node_uid doc_uid parent_uid kind name vocabulary node_id))

131 (emit "NODE_COUNT" (length (graph-nodes g)))

132 0)

133 ((equal? cmd "edges")

134 (rows->lines "EDGE" (graph-edges g)

135 '(src_uid kind kind_known declared ordinal

136 dst_workspace dst_slug dst_node dst_uid resolution))

137 (emit "EDGE_COUNT" (length (graph-edges g)))

138 0)

139 ((equal? cmd "spans")

140 (rows->lines "SPAN" (graph-spans g)

141 '(owner_kind owner_uid part byte_start byte_length

142 scalar_start scalar_end line column_no))

143 (emit "SPAN_COUNT" (length (graph-spans g)))

144 0)

145 ((equal? cmd "revisions")

146 (rows->lines "REVISION" (graph-revisions g) '(doc_uid revision))

147 (emit "REVISION_COUNT" (length (graph-revisions g)))

148 0)

149 ((equal? cmd "diagnostics")

150 (rows->lines "DIAGNOSTIC" (graph-diagnostics g)

151 '(doc_uid ordinal severity code message))

152 (emit "DIAGNOSTIC_COUNT" (length (graph-diagnostics g)))

153 0)

154 ((equal? cmd "backlinks")

155 (let ((groups (graph-backlinks-by-kind g (car extra))))

156 (for-each (lambda (grp)

157 (for-each (lambda (s) (emit "BACKLINK" (car grp) s)) (cdr grp)))

158 groups)

159 (emit "BACKLINK_KINDS" (length groups)))

160 0)

161 ((equal? cmd "cycles")

162 (let ((cs (graph-dependency-cycles g)))

163 (for-each (lambda (c)

164 ;; the ring, then its entry point again, so the

165 ;; printed form closes visibly

166 (emit "CYCLE" (string-join (append c (list (car c))) " -> ")))

167 cs)

168 (emit "CYCLE_COUNT" (length cs)))

169 0)

170 ((equal? cmd "supersessions")

171 (let ((ss (graph-supersession-chains g)))

172 (for-each (lambda (p) (emit "SUPERSEDES" (cadr p) (car p))) ss)

173 (emit "SUPERSESSION_COUNT" (length ss)))

174 0)

175 ((equal? cmd "unresolved")

176 (rows->lines "UNRESOLVED" (graph-unresolved-targets g)

177 '(src_uid kind dst_workspace dst_slug dst_node resolution))

178 (emit "UNRESOLVED_COUNT" (length (graph-unresolved-targets g)))

179 0)

180 ((equal? cmd "orphans")

181 (rows->lines "ORPHAN" (graph-orphans g) '(doc_uid))

182 (emit "ORPHAN_COUNT" (length (graph-orphans g)))

183 0)

184 ((equal? cmd "search")

185 (rows->lines "HIT" (graph-search g (car extra)) '(doc_uid slug title))

186 (emit "HIT_COUNT" (length (graph-search g (car extra))))

187 0)

188 ((equal? cmd "meta")

189 (emit "SCHEMA_VERSION" (graph-schema-version))

190 (emit "OPEN_STATE" (graph-open-state g))

191 0)

192 (else

193 (display (format "f4a_graph_probe: unknown command: ~a~%" cmd))

194 2))))))))

195

196;; The terminal marker prints only on a path that RETURNED. A raise inside the

197;; product skips it, so the gate can tell "the probe ran and found nothing" from

198;; "the probe died before it could find anything" -- two states that otherwise

199;; both render as an empty result set, which is the failure this whole module's

200;; checked-SQLite layer exists to prevent one level down.

201(let* ((argv (args-after-script (command-line)))

202 (rc (main-probe argv)))

203 (emit "PROBE_DONE" (if (null? argv) "-" (car argv)) rc)

204 (exit rc))