Restore LSP request timeouts
ober
306a96ac70988651ad94a3b23f2ef09e654d306f
--- a/src/jerboa-emacs/qt/lsp-client.ss +++ b/src/jerboa-emacs/qt/lsp-client.ss @@ -31,6 +31,65 @@ ;; Pending requests: id -> callback thunk (called with response hash on UI thread) (def *lsp-pending-requests* (make-hash-table)) (def *lsp-pending-mutex* (make-mutex 'lsp-pending)) +(def *lsp-request-timeouts* (make-hash-table)) +(def *lsp-timeout-mutex* (make-mutex 'lsp-timeouts)) +(def *lsp-timeout-sweep-started?* #f) + +(def (lsp-timeout-delay-ms timeout-seconds) + "Convert a timeout value in seconds to a non-negative millisecond interval." + (max 0 (inexact->exact (ceiling (* timeout-seconds 1000))))) + +(def (lsp-store-timeout! id deadline-ms on-timeout method) + "Remember the timeout metadata for request ID." + (mutex-lock! *lsp-timeout-mutex*) + (unwind-protect + (hash-put! *lsp-request-timeouts* id (list deadline-ms on-timeout method)) + (mutex-unlock! *lsp-timeout-mutex*))) + +(def (lsp-clear-timeout! id) + "Clear timeout metadata for request ID, if present." + (mutex-lock! *lsp-timeout-mutex*) + (unwind-protect + (when (hash-get *lsp-request-timeouts* id) + (hash-remove! *lsp-request-timeouts* id)) + (mutex-unlock! *lsp-timeout-mutex*))) + +(def (lsp-take-expired-timeouts! now-ms) + "Return expired timeout entries and remove them from timeout tracking." + (mutex-lock! *lsp-timeout-mutex*) + (unwind-protect + (let loop ((entries (hash->list *lsp-request-timeouts*)) (expired [])) + (if (null? entries) expired + (let* ((entry (car entries)) + (id (car entry)) + (info (cdr entry)) + (deadline-ms (car info))) + (if (<= deadline-ms now-ms) + (begin + (hash-remove! *lsp-request-timeouts* id) + (loop (cdr entries) (cons (cons id info) expired))) + (loop (cdr entries) expired))))) + (mutex-unlock! *lsp-timeout-mutex*))) + +(def (lsp-timeout-sweep!) + "Expire LSP requests whose timeout has elapsed. Runs on the UI timer." + (for-each + (lambda (entry) + (let* ((id (car entry)) + (info (cdr entry)) + (on-timeout (cadr info)) + (method (caddr info))) + (when (lsp-take-pending! id) + (jemacs-log! "LSP: request timed out: " method) + (when on-timeout + (on-timeout))))) + (lsp-take-expired-timeouts! (current-time-ms)))) + +(def (lsp-ensure-timeout-sweep!) + "Ensure the UI-thread timeout sweeper is registered once." + (unless *lsp-timeout-sweep-started?* + (set! *lsp-timeout-sweep-started?* #t) + (schedule-periodic! 'lsp-timeouts 50 lsp-timeout-sweep!))) ;; UI action queue — now uses unified async ui-queue (channel-based) @@ -80,7 +139,9 @@ (mutex-lock! *lsp-pending-mutex*) (unwind-protect (let ((cb (hash-get *lsp-pending-requests* id))) - (when cb (hash-remove! *lsp-pending-requests* id)) + (when cb + (hash-remove! *lsp-pending-requests* id) + (lsp-clear-timeout! id)) cb) (mutex-unlock! *lsp-pending-mutex*))) @@ -199,15 +260,17 @@ id))) (def (lsp-send-request/timeout! method params callback - timeout: (timeout 5.0) - on-timeout: (on-timeout #f)) + (timeout 5.0) + (on-timeout #f)) "Send a JSON-RPC request with timeout (seconds). If no response arrives within timeout, remove the pending callback and call on-timeout on UI thread." - ;; NOTE: timeout enforcement removed to avoid spawning Chez threads - ;; (which cause GC deadlocks in SMP mode). The LSP request will either - ;; succeed via the normal response path, or the pending callback will - ;; remain unused. Users will notice if the server is unresponsive. (let ((id (lsp-send-request! method params callback))) + (when id + (lsp-ensure-timeout-sweep!) + (lsp-store-timeout! id + (+ (current-time-ms) (lsp-timeout-delay-ms timeout)) + on-timeout + method)) id)) (def (lsp-send-notification! method params) @@ -413,6 +476,7 @@ ;; The 'lsp-reader periodic task becomes a no-op when *lsp-process* is #f (set! *lsp-request-id* 0) (set! *lsp-pending-requests* (make-hash-table)) + (set! *lsp-request-timeouts* (make-hash-table)) (set! *lsp-initialized* #f) (set! *lsp-initializing* #f) (set! *lsp-server-capabilities* (make-hash-table)) --- a/tests/test-qt.ss +++ b/tests/test-qt.ss @@ -1500,6 +1500,48 @@ (set! *lsp-initializing* old-initializing) (set-box! *lsp-show-message-handler* old-handler)))))) + (test-case "LSP request timeout removes pending callback and reports" + (let ((old-proc *lsp-process*) + (old-initialized *lsp-initialized*) + (old-initializing *lsp-initializing*) + (old-pending *lsp-pending-requests*) + (old-timeouts *lsp-request-timeouts*) + (old-request-id *lsp-request-id*) + (called #f) + (timed-out #f)) + (let-values (((port extract) (open-bytevector-output-port))) + (unwind-protect + (begin + (set! *lsp-process* port) + (set! *lsp-initialized* #t) + (set! *lsp-initializing* #f) + (set! *lsp-pending-requests* (make-hash-table)) + (set! *lsp-request-timeouts* (make-hash-table)) + (set! *lsp-request-id* 0) + (let ((id (lsp-send-request/timeout! + "textDocument/hover" #f + (lambda (msg) (set! called #t)) + 0.0 + (lambda () (set! timed-out #t))))) + (unless (equal? id 1) + (error 'lsp-timeout-test "request id was not allocated")) + (when called + (error 'lsp-timeout-test "response callback fired before timeout")) + (lsp-timeout-sweep!) + (unless timed-out + (error 'lsp-timeout-test "timeout callback was not called")) + (when called + (error 'lsp-timeout-test "response callback fired after timeout")) + (when (lsp-take-pending! id) + (error 'lsp-timeout-test "pending callback survived timeout")))) + (begin + (set! *lsp-process* old-proc) + (set! *lsp-initialized* old-initialized) + (set! *lsp-initializing* old-initializing) + (set! *lsp-pending-requests* old-pending) + (set! *lsp-request-timeouts* old-timeouts) + (set! *lsp-request-id* old-request-id)))))) + ;;;============================================================================ ;;; Phase 20: Code folding (Group 15 from upstream) ;;;============================================================================