test/test-write-safety.sgl

1;;; Regression tests for concurrent writers sharing one folio root.

2;;;

3;;; Every session runs its own folio process against the same root. Writes

4;;; truncated the file in place with no lock, so concurrent appends were lost

5;;; and a process reading mid-write could persist a note shrunk to nothing

6;;; but its own appended text.

7;;;

8;;; The MCP groups drive the built binary: build/release/bin/folio, else

9;;; build/dev/bin/folio, unless FOLIO_TEST_BINARY names one. Logs go to a file

10;;; because nothing reads the child's stderr, and a full stderr pipe blocks it. Spawned children

11;;; inherit the other children's stdin pipes, so every stdin is closed before

12;;; any output is collected; otherwise no child sees EOF.

14(import (sigil test)

15 (sigil string)

16 (sigil io)

17 (sigil fs)

18 (sigil path)

19 (sigil json)

20 (sigil dict)

21 (sigil time)

22 (sigil random)

23 (sigil process)

24 (sigil sqlite)

25 (sigil async)

26 (folio store)

27 (folio lock))

29(define (folio-binary)

30 (or (getenv "FOLIO_TEST_BINARY")

31 (let loop ((rest (list "build/release/bin/folio" "build/dev/bin/folio")))

32 (cond

33 ((null? rest) #f)

34 ((file-exists? (car rest)) (car rest))

35 (else (loop (cdr rest)))))))

37(define (make-root label)

38 (let ((root (string-append (or (getenv "TMPDIR") "/tmp")

39 "/folio-write-safety-" label "-"

40 (number->string (current-second)) "-"

41 (number->string (random-integer 1000000000)))))

42 (make-directory root)

43 (make-directory (path-join root "notes"))

44 (make-directory (path-join root "projects"))

45 (make-directory (path-join root "archive"))

46 (make-directory (path-join root "archive" "projects"))

47 (make-directory (path-join root "archive" "notes"))

48 (write-file-string (path-join root "inbox.md") "")

49 root))

51(define (big-body n)

52 (let loop ((i 0) (acc '()))

53 (if (= i n)

54 (string-join (reverse acc) "\n")

55 (loop (+ i 1)

56 (cons (string-append "Line " (number->string i)

57 " of a note long enough that rewriting it is not instant.")

58 acc)))))

60(define (seed-note! root name body)

61 (let ((path (path-join root "notes" (string-append name ".md"))))

62 (write-file-string path

63 (string-append "---\ntags:\n - topic\ncreated: 2026-01-01\n---\n\n# " name "\n\n"

64 body "\n\nTAIL-SENTINEL\n"))

65 path))

67(define (rpc id method params-json)

68 (string-append "{\"jsonrpc\":\"2.0\",\"id\":" (number->string id)

69 ",\"method\":\"" method "\",\"params\":" params-json "}"))

71(define (tool-call id tool args-json)

72 (rpc id "tools/call"

73 (string-append "{\"name\":\"folio/" tool "\",\"arguments\":" args-json "}")))

75(define (spawn-folio root)

76 (setenv! "FOLIO_ROOT" root)

77 (let ((p (process-spawn (folio-binary) "serve" "--log" (path-join root "folio-test.log"))))

78 (send! p (rpc 1 "initialize" "{\"protocolVersion\":\"2025-11-25\",\"capabilities\":{}}"))

79 (send! p "{\"jsonrpc\":\"2.0\",\"method\":\"notifications/initialized\"}")

80 p))

82(define (send! p line)

83 (display line (process-stdin p))

84 (newline (process-stdin p))

85 (flush-output-port (process-stdin p)))

87(define (finish! p n)

88 (close-output-port (process-stdin p))

89 (collect! p n))

91(define (collect! p n)

92 (let loop ((left n) (acc '()))

93 (if (zero? left)

94 (begin (process-wait p) (reverse acc))

95 (let ((line (read-line (process-stdout p))))

96 (if (eof-object? line)

97 (begin (process-wait p) (reverse acc))

98 (loop (- left 1) (cons line acc)))))))

100(define (run-calls root calls)

101 (let ((p (spawn-folio root)))

102 (let loop ((cs calls) (id 2))

103 (unless (null? cs)

104 (send! p (tool-call id (car (car cs)) (cdr (car cs))))

105 (loop (cdr cs) (+ id 1))))

106 (let ((lines (finish! p (+ 1 (length calls)))))

107 (if (pair? lines) (cdr lines) '()))))

108

109(define (error-response? line)

110 (string-contains? line "\"error\""))

111

112(define (count-occurrences haystack needle)

113 (let loop ((from 0) (n 0))

114 (let ((at (string-find haystack needle from)))

115 (if at (loop (+ at (string-length needle)) (+ n 1)) n))))

116

117(test-group "concurrent appends from several processes are all kept"

118 (if (not (folio-binary))

119 (test "skipped: folio binary not built" (assert-true #t))

120 (let* ((root (make-root "concurrent"))

121 (body (big-body 3000))

122 (path (seed-note! root "big" body))

123 (writers 4)

124 (appends 8)

125 (procs (map (lambda (i) (spawn-folio root)) (iota writers))))

126 (let each ((i 0) (ps procs))

127 (unless (null? ps)

128 (let loop ((j 0))

129 (when (< j appends)

130 (send! (car ps) (tool-call (+ j 2) "note-edit"

131 (string-append "{\"name\":\"big\",\"append\":\"\\n\\nMARK-"

132 (number->string i) "-" (number->string j) "\\n\"}")))

133 (loop (+ j 1))))

134 (each (+ i 1) (cdr ps))))

135 (for-each (lambda (p) (close-output-port (process-stdin p))) procs)

136

        (let* ((responses (apply append (map (lambda (p) (let ((ls (collect! p (+ 1 appends)))) (if (pair? ls) (cdr ls) '()))) procs)))

137 (after (read-file-string path)))

138 (test "every append got a response"

139 (assert-equal (* writers appends) (length responses)))

140 (test "every append reported success"

141 (assert-equal '() (filter error-response? responses)))

142 (test "every appended marker is in the file"

143 (assert-equal (* writers appends) (count-occurrences after "MARK-")))

144 (test "frontmatter survived"

145 (assert-true (string-starts-with? after "---\n")))

146 (test "the original body survived"

147 (assert-true (and (string-contains? after body)

148 (string-contains? after "TAIL-SENTINEL"))))))))

149

150(define (lock-held-elsewhere? store)

151 (let* ((db (sqlite-open (store-lock-path store)))

152 (saved (sqlite-busy-budget))

153 (_ (sqlite-set-busy-budget! 0))

154 (got (guard (e (else #f))

155 (sqlite-exec db "BEGIN IMMEDIATE")

156 #t)))

157 (sqlite-set-busy-budget! saved)

158 (when got (sqlite-exec db "ROLLBACK"))

159 (sqlite-close db)

160 (not got)))

161

162(test-group "call-with-store-lock"

163 (let* ((root (make-root "lock"))

164 (store (make-folio-store root)))

165 (test "excludes other connections while held"

166 (assert-true (call-with-store-lock store (lambda () (lock-held-elsewhere? store)))))

167 (test "returns the thunk's value and releases"

168 (assert-equal 42 (call-with-store-lock store (lambda () 42)))

169 (assert-false (lock-held-elsewhere? store)))

170 (test "refuses, rather than runs unlocked, when the lock file is not a database"

171 (let* ((bad-root (make-root "badlock"))

172 (bad-store (make-folio-store bad-root))

173 (ran #f))

174 (write-file-string (store-lock-path bad-store) "this is not an sqlite database, it is text")

175 (assert-equal 'raised

176 (guard (e (#t 'raised))

177 (call-with-store-lock bad-store (lambda () (set! ran #t) 'ran))))

178 (assert-false ran)))

179 (test "releases when the thunk raises"

180 (assert-equal 'raised

181 (guard (e (#t 'raised))

182 (call-with-store-lock store (lambda () (error "boom")))))

183 (assert-false (lock-held-elsewhere? store)))

184 (test "waits for another holder instead of failing"

185 (let ((holder (sqlite-open (store-lock-path store)))

186 (order '()))

187 (sqlite-exec holder "BEGIN IMMEDIATE")

188 (with-async

189 (go (begin

190 (sleep 0.2)

191 (set! order (cons 'released order))

192 (sqlite-exec holder "ROLLBACK")))

193 (go (call-with-store-lock store

194 (lambda () (set! order (cons 'acquired order))))))

195 (sqlite-close holder)

196 (assert-equal '(acquired released) order)))))

197

198(test-group "write-file-atomic"

199 (let* ((root (make-root "atomic"))

200 (path (path-join root "note.md")))

201 (write-file-string path "old content")

202 (write-file-atomic path "new content")

203 (test "replaces the content"

204 (assert-equal "new content" (read-file-string path)))

205 (test "a reader that opened the file before the write still reads all of it"

206 (let ((before (big-body 2000)))

207 (write-file-string path before)

208 (let ((port (open-input-file path)))

209 (write-file-atomic path "short")

210 (let ((seen (read-string (+ 1 (string-length before)) port)))

211 (close-input-port port)

212 (assert-equal before seen)))))

213 (test "leaves no temporary file behind"

214 (assert-equal '("note.md")

215 (filter (lambda (n) (not (member n '("inbox.md" "notes" "projects" "archive"))))

216 (directory-list root))))))

217

218(test-group "concurrent task-adds from several processes are all kept"

219 (if (not (folio-binary))

220 (test "skipped: folio binary not built" (assert-true #t))

221 (let* ((root (make-root "tasks"))

222 (writers 4)

223 (adds 8)

224 (procs (map (lambda (i) (spawn-folio root)) (iota writers))))

225 (let each ((i 0) (ps procs))

226 (unless (null? ps)

227 (let loop ((j 0))

228 (when (< j adds)

229 (send! (car ps) (tool-call (+ j 2) "task-add"

230 (string-append "{\"text\":\"TASK-" (number->string i)

231 "-" (number->string j) "\"}")))

232 (loop (+ j 1))))

233 (each (+ i 1) (cdr ps))))

234 (for-each (lambda (p) (close-output-port (process-stdin p))) procs)

235

        (let* ((responses (apply append (map (lambda (p) (let ((ls (collect! p (+ 1 adds)))) (if (pair? ls) (cdr ls) '()))) procs)))

236 (inbox (read-file-string (path-join root "inbox.md"))))

237 (test "every task-add reported success"

238 (assert-equal '() (filter error-response? responses)))

239 (test "every task is in the inbox"

240 (assert-equal (* writers adds) (count-occurrences inbox "TASK-")))))))

241

242(define (dummy-arg spec)

243 (if (equal? (dict-ref spec type: "string") "array") "[\"x\"]" "\"x\""))

244

245(define (dummy-args schema)

246 (let* ((props (dict-ref schema properties: (dict)))

247 (required (let ((r (dict-ref schema required: '()))) (if (list? r) r (array->list r)))))

248 (string-append "{"

249 (string-join (map (lambda (k)

250 (string-append "\"" k "\":"

251 (dummy-arg (dict-ref props (string->keyword k)))))

252 required)

253 ",")

254 "}")))

255

256(define expected-unlocked

257 '("folio/task-notes" "folio/projects" "folio/project-info" "folio/notes"

258 "folio/note-read" "folio/note-links" "folio/tasks" "folio/status"

259 "folio/rebuild-index"))

260

261(test-group "every tool that can write waits for the store lock"

262 (if (not (folio-binary))

263 (test "skipped: folio binary not built" (assert-true #t))

264 (let* ((root (make-root "inventory"))

265 (store (make-folio-store root))

266 (lister (spawn-folio root)))

267 (send! lister (rpc 2 "tools/list" "{}"))

268 (let* ((listed (dict-ref (dict-ref (json-decode (cadr (finish! lister 2))) result:) tools:))

269 (tools (if (list? listed) listed (array->list listed)))

270 (holder (sqlite-open (store-lock-path store))))

271 (sqlite-exec holder "BEGIN IMMEDIATE")

272 (setenv! "FOLIO_LOCK_TIMEOUT" "0.2")

273 (let ((p (spawn-folio root)))

274 (setenv! "FOLIO_LOCK_TIMEOUT" "60")

275 (let loop ((ts tools) (id 2))

276 (unless (null? ts)

277 (send! p (tool-call id (string-copy (dict-ref (car ts) name:) 6)

278 (dummy-args (dict-ref (car ts) inputSchema:))))

279 (loop (cdr ts) (+ id 1))))

280 (let* ((responses (let ((ls (finish! p (+ 1 (length tools))))) (if (pair? ls) (cdr ls) '())))

281 (waited (let collect ((ts tools) (rs responses) (acc '()))

282 (if (or (null? ts) (null? rs))

283 (reverse acc)

284 (collect (cdr ts) (cdr rs)

285 (if (string-contains? (car rs) "waiting for folio write lock")

286 (cons (dict-ref (car ts) name:) acc)

287 acc)))))

288 (expected (filter (lambda (n) (not (member n expected-unlocked)))

289 (map (lambda (t) (dict-ref t name:)) tools))))

290 (sqlite-exec holder "ROLLBACK")

291 (sqlite-close holder)

292 (test "every tool answered"

293 (assert-equal (length tools) (length responses)))

294 (test "exactly the writing tools waited for the lock"

295 (assert-equal expected waited))

296 (test "they gave up after FOLIO_LOCK_TIMEOUT, not the default"

297 (assert-equal '()

298 (filter (lambda (r)

299 (and (string-contains? r "waiting for folio write lock")

300 (not (string-contains? r "limit 0.2s"))))

301 responses)))))))))

302

303(test-group "an error inside a locked handler gets its own reply"

304 (if (not (folio-binary))

305 (test "skipped: folio binary not built" (assert-true #t))

306 (let* ((root (make-root "error-reply"))

307 (_ (seed-note! root "n" "Body."))

308 (lines (run-calls root

309 (list (cons "note-patch" "{\"name\":\"n\",\"patches\":[{\"old\":\"NOT THERE\",\"new\":\"x\"}]}")

310 (cons "note-edit" "{\"name\":\"n\",\"append\":\"\\nok\\n\"}")))))

311 (test "the failing call's reply is an error with its own id"

312 (assert-true (and (pair? lines)

313 (error-response? (car lines))

314 (string-contains? (car lines) "\"id\":2"))))

315 (test "the next call's reply carries the next id"

316 (assert-true (and (= 2 (length lines))

317 (string-contains? (cadr lines) "\"id\":3")))))))

318

319(test-group "no module writes files except through write-file-atomic"

320 (let ((offenders

321 (filter (lambda (f)

322 (and (string-ends-with? f ".sgl")

323 (not (equal? f "lock.sgl"))

324 (string-contains? (read-file-string (path-join "src/folio" f))

325 "(write-file-string")))

326 (directory-list "src/folio"))))

327 (test "only lock.sgl calls write-file-string"

328 (assert-equal '() offenders))))

329

330

331(define (old-reader-survives? path run!)

332 (let* ((before (read-file-string path))

333 (port (open-input-file path)))

334 (run!)

335 (let ((seen (read-string (+ 1 (string-length before)) port)))

336 (close-input-port port)

337 (and (not (eof-object? seen)) (equal? before seen)))))

338

339(test-group "real write paths replace files rather than truncating them"

340 (if (not (folio-binary))

341 (test "skipped: folio binary not built" (assert-true #t))

342 (let* ((root (make-root "write-paths"))

343 (note (seed-note! root "big" (big-body 2000)))

344 (project (path-join root "projects" "src.md")))

345 (write-file-string project

346 (string-append "---\nstatus: active\ngoal: g\n---\n\n# src\n\n## Tasks\n\n"

347 "- [ ] keep me {id: t-aaaaaa}\n- [ ] move me {id: t-bbbbbb}\n"

348 (big-body 2000) "\n"))

349 (test "note-edit append leaves a reader's open file whole"

350 (assert-true (old-reader-survives? note

351

                         (lambda () (run-calls root (list (cons "note-edit" "{\"name\":\"big\",\"append\":\"\\nX\\n\"}")))))))

352 (test "task-move leaves a reader's open source project whole"

353 (assert-true (old-reader-survives? project

354 (lambda () (run-calls root (list (cons "task-move" "{\"id\":\"t-bbbbbb\"}")))))))

355 (test "and the move itself happened"

356 (assert-true (and (not (string-contains? (read-file-string project) "move me"))

357 (string-contains? (read-file-string (path-join root "inbox.md")) "move me")))))))

358

359(test-group "project tool names cannot escape the projects directory"

360 (if (not (folio-binary))

361 (test "skipped: folio binary not built" (assert-true #t))

362 (let* ((root (make-root "project-traversal"))

363 (outside (path-join root "outside.md"))

364 (original "# Outside\n\n## Tasks\n\n## Log\n"))

365 (write-file-string outside original)

366 (let ((replies

367 (run-calls root

368 (list

369 (cons "project-info" "{\"name\":\"../outside\"}")

370 (cons "task-add" "{\"project\":\"../outside\",\"text\":\"Must not land\"}")

371 (cons "project-log" "{\"name\":\"../outside\",\"entry\":\"Must not land\"}")))))

372 (test "all project entry points refuse traversal with an error reply"

373 (assert-equal 3 (length replies))

374 (assert-equal 3 (length (filter error-response? replies))))

375 (test "the escaped file remains byte-identical"

376 (assert-equal original (read-file-string outside)))))))