tools/check-backlink-corpus.sgl

1;;; Differential and timing check for a disposable Markdown corpus.

2;;; Run with FOLIO_CORPUS pointing to a private copy, never a live store.

3(import (sigil fs)

4 (sigil string)

5 (sigil list)

6 (sigil time)

7 (sigil process)

8 (sigil sqlite)

9 (sigil mcp server)

10 (sigil mcp protocol)

11 (folio store)

12 (folio note)

13 (folio project)

14 (folio links)

15 (folio index)

16 (folio query)

17 (folio tools))

19(define root (getenv "FOLIO_CORPUS"))

20(unless root (error "FOLIO_CORPUS must name a disposable corpus copy"))

21(define store (make-folio-store root))

23(define (cpu-ms)

24 (/ (string->number

25 (car (string-split (read-file-string "/proc/self/schedstat") " ")))

26 1000000.0))

28(define (wall-ms)

29 (* 1000.0 (/ (current-jiffy) (jiffies-per-second))))

31(define (measure label thunk)

32 (let* ((cpu (cpu-ms))

33 (wall (wall-ms))

34 (value (thunk))

35 (elapsed (- (wall-ms) wall))

36 (used (- (cpu-ms) cpu)))

37 (display (format "~a wall_ms=~a cpu_ms=~a\n" label elapsed used))

38 (flush-output-port (current-output-port))

39 value))

41(define notes (measure "oracle_load_notes" (lambda () (all-notes store))))

42(define names (map folio-note-name notes))

43(define incoming (dict))

45;; This is the old source traversal, executed once for all targets: a source

46;; contributes at most one backlink for each literal target, in traversal order.

47(define (record-source! name kind targets)

48 (let ((seen (dict)))

49 (for-each

50 (lambda (target)

51 (unless (dict-contains? seen target)

52 (set! seen (dict-set seen target #t))

53 (set! incoming

54 (dict-set incoming target

55 (cons (cons name kind) (dict-ref incoming target '()))))))

56 targets)))

58(for-each

59 (lambda (note)

60 (record-source! (folio-note-name note) 'note (note-outgoing-links note)))

61 notes)

62(for-each

63 (lambda (project)

64 (record-source! (folio-project-name project) 'project

65 (extract-crosslinks (read-file-string (folio-project-file-path project)))))

66 (all-projects store))

68(define (oracle-backlinks name)

69 (reverse (dict-ref incoming name '())))

71;; Validate the amortized oracle against the actual old implementation too.

72(define sample-names

73 (let* ((count (min 25 (length names)))

74 (stride (max 1 (quotient (length names) (max 1 count)))))

75 (let loop ((i 0) (out '()))

76 (if (= i count)

77 (reverse out)

78 (loop (+ i 1) (cons (list-ref names (* i stride)) out))))))

80(define (percentile samples p)

81 (list-ref (list-sort < samples)

82 (max 0 (- (quotient (+ (* p (length samples)) 99) 100) 1))))

84(define (benchmark label lookup expected)

85 (let loop ((rest sample-names) (walls '()) (cpus '()))

86 (if (null? rest)

87 (begin

88 (display

89 (format "~a n=~a wall_p50_ms=~a wall_p95_ms=~a cpu_p50_ms=~a cpu_p95_ms=~a\n"

90 label (length walls) (percentile walls 50) (percentile walls 95)

91 (percentile cpus 50) (percentile cpus 95)))

92 (flush-output-port (current-output-port)))

93 (let* ((cpu (cpu-ms))

94 (wall (wall-ms))

95 (actual (lookup (car rest)))

96 (elapsed (- (wall-ms) wall))

97 (used (- (cpu-ms) cpu)))

98 (unless (equal? actual (expected (car rest)))

99 (error "Benchmark backlink mismatch" (car rest)))

100 (loop (cdr rest) (cons elapsed walls) (cons used cpus))))))

101

102(define (old-note-links-output note backlinks)

103 (let* ((name (folio-note-name note))

104 (tasks (note-tasks note))

105 (outgoing (all-links store (folio-note-body note))))

106 (string-append

107 (format "Links for ~a:\n\n" name)

108 (if (null? tasks)

109 ""

110 (string-append " Tasks: "

111 (string-join (map (lambda (task) (format "~a" task)) tasks) ", ") "\n"))

112 (if (null? outgoing)

113 " Outgoing: none\n"

114 (string-append " Outgoing:\n"

115 (string-join

116 (map (lambda (link) (format " → ~a (~a)" (car link) (cadr link))) outgoing)

117 "\n") "\n"))

118 "\n"

119 (if (null? backlinks)

120 " Backlinks: none\n"

121 (string-append " Backlinks:\n"

122 (string-join

123 (map (lambda (link) (format " ← ~a (~a)" (car link) (cdr link))) backlinks)

124 "\n") "\n")))))

125

126(define (expected-output name)

127 (old-note-links-output

128 (read-note (find-note-file store name) (store-notes-dir store))

129 (oracle-backlinks name)))

130

131(unless (getenv "FOLIO_SKIP_OLD_BENCHMARK")

132 (benchmark "before_backlinks" (lambda (name) (find-all-backlinks store name)) oracle-backlinks)

133 (benchmark "before_note_links"

134 (lambda (name)

135 (old-note-links-output

136 (read-note (find-note-file store name) (store-notes-dir store))

137 (find-all-backlinks store name)))

138 expected-output))

139(define idx (measure "open_index" (lambda () (make-folio-index store))))

140(measure "first_reconcile" (lambda () (index-reconcile! idx)))

141(benchmark "after_backlinks" (lambda (name) (index-backlinks idx name)) oracle-backlinks)

142

143(define server (mcp-server name: "corpus-check"))

144(register-folio-tools! server store idx)

145(define (tool-text name args)

146 (let ((response

147 (mcp-server-handle-message server

148 (jsonrpc-request id: 1 method: "tools/call"

149 params: (dict name: name arguments: args)))))

150 (unless (jsonrpc-response? response) (error "Tool returned an error" name))

151 ;; Include the same JSON serialization the stdio transport performs.

152 (response->json response)

153 (cdr (assoc 'text

154 (car (cdr (assoc 'content (jsonrpc-response-result response))))))))

155

156(benchmark "after_note_links"

157 (lambda (name) (tool-text "folio/note-links" (dict name: name)))

158 expected-output)

159

160(measure "all_note_backlinks_differential"

161 (lambda ()

162 (for-each

163 (lambda (name)

164 (unless (equal? (oracle-backlinks name) (index-backlinks idx name))

165 (error "Differential backlink mismatch" name)))

166 names)))

167(display (format "DIFFERENTIAL_OK notes=~a\n" (length names)))

168

169(measure "all_note_links_output_differential"

170 (lambda ()

171 (for-each

172 (lambda (note)

173 (let ((name (folio-note-name note)))

174 (unless (equal? (old-note-links-output note (oracle-backlinks name))

175 (tool-text "folio/note-links" (dict name: name)))

176 (error "Differential note-links output mismatch" name))))

177 notes)))

178(display (format "OUTPUT_DIFFERENTIAL_OK notes=~a\n" (length names)))

179

180(measure "status_tool"

181 (lambda ()

182 (let ((text (tool-text "folio/status" (dict))))

183 (unless (string-starts-with? text "# Folio Status")

184 (error "Status did not complete successfully"))

185 (display (format "status_response_chars=~a\n" (string-length text))))))

186

187(define previous-orphans

188 (map folio-note-name (find-orphaned-notes store notes)))

189(define indexed-orphans (index-orphan-names idx))

190(unless (equal? (list-sort string<? previous-orphans)

191 (list-sort string<? indexed-orphans))

192 (error "Differential orphan mismatch"))

193(display "ORPHAN_DIFFERENTIAL_OK\n")

194(sqlite-close (folio-index-db idx))

195(define reopened (measure "reopen_index" (lambda () (make-folio-index store))))

196(measure "persisted_reconcile" (lambda () (index-reconcile! reopened)))

197(benchmark "reopened_backlinks" (lambda (name) (index-backlinks reopened name)) oracle-backlinks)

198(sqlite-close (folio-index-db reopened))

199(display "CORPUS_CHECK_OK\n")