Avoid legacy session DB on active chat path
ober
03383dc9eb6fe1cab4a579050556a8bc7d6f9d8c
--- a/src/jcode/core/session.ss +++ b/src/jcode/core/session.ss @@ -20,6 +20,7 @@ (only (jsqlite value) sql-null sql-null?) :std/misc/uuid :std/misc/thread + :std/misc/string :std/os/path :std/text/json ./config @@ -27,9 +28,8 @@ (defstruct session (id title created messages)) -;; jsqlite uses a sidecar flock file. Concurrent session DB opens from -;; multiple jcode threads can deadlock inside flock, so serialize access -;; within this process before entering SQLite. +;; Session storage is process-serialized because both the legacy jsqlite +;; database and the file-backed store mutate shared files. (def *session-db-mutex* (make-mutex)) (def (with-session-db-lock thunk) @@ -38,6 +38,227 @@ thunk (lambda () (mutex-unlock! *session-db-mutex*)))) +;; New sessions are stored as small per-session files. The old global +;; sessions.db is kept only as a lazy legacy fallback: jsqlite loads and +;; rewrites the whole database image, so a large historical DB must not be +;; touched during every active chat turn. +(def (session-store-dir) + (path-join (jcode-home) "sessions")) + +(def (ensure-dir! path) + (unless (file-exists? path) (mkdir path))) + +(def (ensure-session-store!) + (ensure-dir! (session-store-dir))) + +(def (safe-session-id? id) + (and (string? id) + (not (string-empty? id)) + (not (string=? id ".")) + (not (string=? id "..")) + (not (string-contains id "/")) + (not (string-contains id "\\")))) + +(def (session-id-component id) + (if (safe-session-id? id) + id + (error 'session-file-store "invalid session id" id))) + +(def (file-session-dir id) + (path-join (session-store-dir) (session-id-component id))) + +(def (file-session-meta-path id) + (path-join (file-session-dir id) "meta.json")) + +(def (file-session-messages-path id) + (path-join (file-session-dir id) "messages.jsonl")) + +(def (file-session-known? id) + (and (read-file-session-meta* id) #t)) + +(def (file-session-exists? id) + (and (read-file-session-meta id) #t)) + +(def (read-string-file path) + (call-with-input-file path get-string-all)) + +(def (write-string-file! path text) + (let ((p (open-file-output-port + path + (file-options no-fail) + (buffer-mode block) + (make-transcoder (utf-8-codec))))) + (dynamic-wind + (lambda () (void)) + (lambda () (display text p)) + (lambda () (close-port p))))) + +(def (session-meta-json id title created updated) + (let ((ht (make-hash-table))) + (hash-put! ht "id" id) + (hash-put! ht "title" title) + (hash-put! ht "created" created) + (hash-put! ht "updated" updated) + ht)) + +(def (write-file-session-meta! id title created updated) + (let ((dir (file-session-dir id))) + (ensure-session-store!) + (ensure-dir! dir) + (write-string-file! + (file-session-meta-path id) + (json-object->string (session-meta-json id title created updated))))) + +(def (read-file-session-meta* id) + (and (safe-session-id? id) + (let ((path (file-session-meta-path id))) + (and (file-exists? path) + (try (string->json-object (read-string-file path)) + (catch (_) #f)))))) + +(def (read-file-session-meta id) + (let ((meta (read-file-session-meta* id))) + (and meta + (not (hash-ref meta "deleted" #f)) + meta))) + +(def (message->file-json-line msg) + (json-object->string (message->json msg))) + +(def (file-json-line->message line) + (json->message (string->json-object line))) + +(def (read-file-session-messages id) + (let ((path (file-session-messages-path id))) + (if (not (file-exists? path)) + '() + (call-with-input-file path + (lambda (p) + (let loop ((acc '())) + (let ((line (get-line p))) + (cond + ((eof-object? line) (reverse acc)) + ((string-empty? line) (loop acc)) + (else + (loop (cons (file-json-line->message line) acc))))))))))) + +(def (write-file-session-messages! id msgs) + (let ((dir (file-session-dir id))) + (ensure-session-store!) + (ensure-dir! dir) + (write-string-file! + (file-session-messages-path id) + (with-output-to-string + (lambda () + (for-each + (lambda (msg) + (display (message->file-json-line msg)) + (newline)) + msgs)))))) + +(def (file-session-create title) + (let ((id (uuid-string)) + (now (timestamp-now))) + (write-file-session-meta! id title now now) + (write-file-session-messages! id '()) + (make-session id title now '()))) + +(def (file-session-load id) + (let ((meta (read-file-session-meta id))) + (and meta + (make-session + (hash-ref meta "id" id) + (hash-ref meta "title" "Untitled") + (hash-ref meta "created" "") + (read-file-session-messages id))))) + +(def (file-session-add-message session-id msg) + (let* ((loaded (file-session-load session-id)) + (msgs (if loaded (session-messages loaded) '())) + (now (timestamp-now))) + (write-file-session-messages! session-id (append msgs (list msg))) + (write-file-session-meta! + session-id + (if loaded (session-title loaded) "Untitled") + (if loaded (session-created loaded) now) + now))) + +(def (file-session-replace-messages session-id msgs) + (let* ((loaded (file-session-load session-id)) + (now (timestamp-now))) + (write-file-session-messages! session-id msgs) + (write-file-session-meta! + session-id + (if loaded (session-title loaded) "Untitled") + (if loaded (session-created loaded) now) + now))) + +(def (file-session-update-title session-id title) + (let* ((loaded (file-session-load session-id)) + (now (timestamp-now))) + (when loaded + (write-file-session-meta! session-id title (session-created loaded) now)))) + +(def (file-session-delete session-id) + (when (safe-session-id? session-id) + (let* ((loaded (file-session-load session-id)) + (now (timestamp-now)) + (meta (session-meta-json + session-id + (if loaded (session-title loaded) "") + (if loaded (session-created loaded) now) + now))) + (hash-put! meta "deleted" #t) + (write-file-session-messages! session-id '()) + (write-string-file! + (file-session-meta-path session-id) + (json-object->string meta))))) + +(def (entry->string entry) + (cond + ((string? entry) entry) + ((symbol? entry) (symbol->string entry)) + (else (format "~a" entry)))) + +(def (file-session-list) + (ensure-session-store!) + (let* ((dir (session-store-dir)) + (pairs + (filter-map + (lambda (entry) + (let* ((id (entry->string entry)) + (meta (and (safe-session-id? id) + (read-file-session-meta id)))) + (and meta + (cons (hash-ref meta "updated" (hash-ref meta "created" "")) + (make-session + (hash-ref meta "id" id) + (hash-ref meta "title" "Untitled") + (hash-ref meta "created" "") + '()))))) + (directory-list dir))) + (sorted (sort (lambda (a b) (string>? (car a) (car b))) pairs))) + (map cdr sorted))) + +(def (file-session-search term) + (let ((matches '())) + (for-each + (lambda (sess) + (let ((loaded (file-session-load (session-id sess)))) + (when loaded + (for-each + (lambda (msg) + (let ((content (message-content msg))) + (when (and content (string-contains content term)) + (set! matches + (cons (list (session-title loaded) + (message-role msg) + content) + matches))))) + (session-messages loaded))))) + (file-session-list)) + (reverse matches))) + (def (db-value v) (if (sql-null? v) #f v)) @@ -61,18 +282,23 @@ (sqlite-exec db "PRAGMA busy_timeout = 5000") db)) -;; Run PROC on a fresh db handle, guaranteeing close even on exception. -(def (with-db proc) - (with-session-db-lock - (lambda () - (let ((db (open-db))) - (dynamic-wind - (lambda () (void)) - (lambda () (proc db)) - (lambda () (sqlite-close db))))))) +;; Run PROC on a fresh legacy db handle, guaranteeing close even on exception. +;; Callers hold *session-db-mutex* when mixing this with the file store. +(def (with-legacy-db proc) + (let ((db (open-db))) + (dynamic-wind + (lambda () (void)) + (lambda () (proc db)) + (lambda () (sqlite-close db))))) (def (session-init-db) - (with-db + ;; Initialize only the active file-backed store. Do not open the legacy + ;; global DB here: old installations can have hundreds of MB of history, and + ;; jsqlite loads the whole image. + (with-session-db-lock ensure-session-store!)) + +(def (legacy-session-init-db) + (with-legacy-db (lambda (db) (sqlite-exec db "CREATE TABLE IF NOT EXISTS sessions ( @@ -90,15 +316,19 @@ tool_calls TEXT, tool_call_id TEXT, created_at TEXT NOT NULL, - FOREIGN KEY (session_id) REFERENCES sessions(id) + FOREIGN KEY (session_id) REFERENCES sessions(id) )") (sqlite-exec db "CREATE INDEX IF NOT EXISTS idx_messages_session ON messages(session_id)")))) (def (session-create title) + (with-session-db-lock + (lambda () (file-session-create title)))) + +(def (legacy-session-create title) (let ((id (uuid-string)) (now (timestamp-now))) - (with-db + (with-legacy-db (lambda (db) (sqlite-exec db "INSERT INTO sessions (id, title, created_at, updated_at) VALUES (?, ?, ?, ?)" @@ -106,19 +336,29 @@ (make-session id title now '()))) (def (session-load id) - (with-db + (with-session-db-lock + (lambda () + (if (file-session-known? id) + (file-session-load id) + (legacy-session-load id))))) + +(def (legacy-session-load id) + (with-legacy-db (lambda (db) - (let ((rows (sqlite-query db - "SELECT id, title, created_at FROM sessions WHERE id = ?" - id))) - (and (not (null? rows)) - (let* ((row (car rows)) - (messages (load-messages db id))) - (make-session - (row-ref row 0) - (row-ref row 1) - (row-ref row 2) - messages))))))) + (legacy-session-load* db id)))) + +(def (legacy-session-load* db id) + (let ((rows (sqlite-query db + "SELECT id, title, created_at FROM sessions WHERE id = ?" + id))) + (and (not (null? rows)) + (let* ((row (car rows)) + (messages (load-messages db id))) + (make-session + (row-ref row 0) + (row-ref row 1) + (row-ref row 2) + messages))))) (def (load-messages db session-id) (let ((rows (sqlite-query db @@ -146,7 +386,13 @@ #f))) (def (session-list) - (with-db + ;; List active file-backed sessions. The legacy DB remains loadable by id, + ;; but enumerating it on startup or in the TUI can reload a huge historical + ;; image and wedge the interface. + (with-session-db-lock file-session-list)) + +(def (legacy-session-list) + (with-legacy-db (lambda (db) (let ((rows (sqlite-query db "SELECT id, title, created_at FROM sessions @@ -160,7 +406,15 @@ rows))))) (def (session-add-message session-id msg) - (with-db + (with-session-db-lock + (lambda () + (if (file-session-exists? session-id) + (file-session-add-message session-id msg) + (unless (file-session-known? session-id) + (legacy-session-add-message session-id msg)))))) + +(def (legacy-session-add-message session-id msg) + (with-legacy-db (lambda (db) (let ((now (timestamp-now)) (tool-calls-json @@ -181,7 +435,16 @@ now session-id))))) (def (session-get-messages session-id) - (with-db + (with-session-db-lock + (lambda () + (cond + ((file-session-exists? session-id) + (read-file-session-messages session-id)) + ((file-session-known? session-id) '()) + (else (legacy-session-get-messages session-id)))))) + +(def (legacy-session-get-messages session-id) + (with-legacy-db (lambda (db) (load-messages db session-id)))) (def (session-replace-messages session-id msgs) @@ -189,8 +452,16 @@ ;; Used by /compact to swap older turns for an LLM-generated summary. (with-session-db-lock (lambda () - (let* ((db (open-db)) - (now (timestamp-now)) + (cond + ((file-session-exists? session-id) + (file-session-replace-messages session-id msgs)) + ((file-session-known? session-id) (void)) + (else (legacy-session-replace-messages session-id msgs)))))) + +(def (legacy-session-replace-messages session-id msgs) + (with-legacy-db + (lambda (db) + (let* ((now (timestamp-now)) (begun? #f) (committed? #f)) (dynamic-wind @@ -228,11 +499,19 @@ (try (sqlite-exec db "ROLLBACK") (catch (_) (void)))) (error 'session-replace-messages "transaction failed" e)))) - (lambda () - (sqlite-close db))))))) + (lambda () (void))))))) (def (session-update-title session-id title) - (with-db + (with-session-db-lock + (lambda () + (cond + ((file-session-exists? session-id) + (file-session-update-title session-id title)) + ((file-session-known? session-id) (void)) + (else (legacy-session-update-title session-id title)))))) + +(def (legacy-session-update-title session-id title) + (with-legacy-db (lambda (db) (sqlite-exec db "UPDATE sessions SET title = ?, updated_at = ? WHERE id = ?" @@ -240,22 +519,51 @@ (def (session-search term) "Search all messages for TERM. Returns list of (session-title role snippet)." - (with-db - (lambda (db) - (let* ((pattern (string-append "%" term "%")) - (rows (sqlite-query db - "SELECT s.title, m.role, m.content - FROM messages m - JOIN sessions s ON s.id = m.session_id - WHERE m.content LIKE ? - ORDER BY m.created_at DESC - LIMIT 50" - pattern))) - (map (lambda (row) - (list (row-ref row 0) - (row-ref row 1) - (row-ref row 2))) - rows))))) + ;; Search active file-backed sessions only. Opening the legacy DB to search + ;; can load hundreds of MB into the interactive process. + (with-session-db-lock + (lambda () (file-session-search term)))) + +(def (recent-window msgs) + (let ((skip (- (length msgs) 16))) + (let loop ((xs msgs) (n skip)) + (cond + ((or (<= n 0) (null? xs)) xs) + (else (loop (cdr xs) (- n 1))))))) + +(def (recent-tool-result-ids recent-first) + (let loop ((msgs recent-first) (ids '())) + (cond + ((null? msgs) ids) + ((equal? (message-role (car msgs)) "tool") + (let ((id (message-tool-call-id (car msgs)))) + (loop (cdr msgs) (if id (cons id ids) ids)))) + (else ids)))) + +(def (recent-assistant-tool-calls recent-first) + (let loop ((msgs recent-first)) + (cond + ((null? msgs) '()) + ((equal? (message-role (car msgs)) "assistant") + (let ((tcs (message-tool-calls (car msgs)))) + (if (and tcs (pair? tcs)) tcs '()))) + (else (loop (cdr msgs)))))) + +(def (missing-tool-call-results msgs) + (let* ((recent-first (reverse (recent-window msgs))) + (answered (recent-tool-result-ids recent-first)) + (calls (recent-assistant-tool-calls recent-first)) + (ids (map tool-call-id calls))) + (filter (lambda (id) (and id (not (member id answered)))) ids))) + +(def (file-session-repair-orphan-tool-calls! session-id) + (let* ((msgs (read-file-session-messages session-id)) + (missing (missing-tool-call-results msgs))) + (when (pair? missing) + (file-session-replace-messages + session-id + (append msgs + (map (lambda (id) (make-tool-result id "(cancelled)")) missing)))))) (def (session-repair-orphan-tool-calls! session-id) "Repair a history that ends with an assistant tool_calls message that @@ -263,7 +571,16 @@ was cancelled mid-tool-execution. The OpenAI-style API requires every tool_call_id to be answered, so we synthesize a '(cancelled)' tool result for each unmatched id." - (with-db + (with-session-db-lock + (lambda () + (cond + ((file-session-exists? session-id) + (file-session-repair-orphan-tool-calls! session-id)) + ((file-session-known? session-id) (void)) + (else (legacy-session-repair-orphan-tool-calls! session-id)))))) + +(def (legacy-session-repair-orphan-tool-calls! session-id) + (with-legacy-db (lambda (db) (let ((rows (sqlite-query db "SELECT id, role, tool_calls, tool_call_id @@ -311,7 +628,14 @@ now session-id))))))))))) (def (session-delete session-id) - (with-db + (with-session-db-lock + (lambda () + (if (file-session-known? session-id) + (file-session-delete session-id) + (legacy-session-delete session-id))))) + +(def (legacy-session-delete session-id) + (with-legacy-db (lambda (db) (sqlite-exec db "DELETE FROM messages WHERE session_id = ?" session-id) (sqlite-exec db "DELETE FROM sessions WHERE id = ?" session-id)))) --- a/test/run.ss +++ b/test/run.ss @@ -275,6 +275,9 @@ (session-init-db) (let* ([session (session-create "concurrency regression")] [sid (session-id session)] + [legacy-db (string-append (getenv "HOME") "/.jcode/sessions.db")] + [messages-file + (string-append (getenv "HOME") "/.jcode/sessions/" sid "/messages.jsonl")] [threads (map (lambda (i) @@ -286,10 +289,22 @@ (format "result-~a" i)))))) '(0 1 2 3 4 5 6 7 8 9 10 11))]) (for-each thread-join! threads) + (check! "new sessions skip legacy sqlite db" + (file-exists? legacy-db) + #f) + (check! "new sessions use file store" + (file-exists? messages-file) + #t) (check! "concurrent session writes persist all messages" (length (session-get-messages sid)) 12) - (session-delete sid)))) + (session-delete sid) + (check! "deleted file session reads empty" + (session-get-messages sid) + '()) + (check! "deleted file session stays off legacy sqlite db" + (file-exists? legacy-db) + #f)))) ;; ── File tool tests ───────────────────────────────────────────────