Add MCP client, LSP integration, plugin system
ober
2a023efcae7081690f4c10f024abf73b064c4d26
new file mode 100644 --- /dev/null +++ b/lib/jcode/core/plugin.sls @@ -0,0 +1,65 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/jcode/core/plugin.ss + +(library (jcode core plugin) + (export init-plugins load-plugin list-plugins) + (import + (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- + getenv path-extension path-absolute? thread? make-mutex + mutex? mutex-name) + (std misc string) (jcode core log) (jcode core config) + (jerboa core) (jerboa runtime)) + (def logger (make-logger "plugin")) + (def *loaded-plugins* '()) + (def (plugin-dirs) + "Return list of directories to scan for plugins." + (let ([home-dir (path-join + (or (getenv "XDG_CONFIG_HOME") + (path-join (getenv "HOME") ".config")) + "jcode" + "plugins")] + [local-dir (path-join + (current-directory) + ".jcode" + "plugins")] + [cfg-dirs (config-ref "pluginDirs")]) + (filter + file-directory? + (append + (if (and cfg-dirs (list? cfg-dirs)) cfg-dirs '()) + (list home-dir local-dir))))) + (def (find-plugins) + "Find all .ss files in plugin directories." + (let ([dirs (plugin-dirs)]) + (apply + append + (map (lambda (dir) + (map (lambda (f) (path-join dir f)) + (filter + (lambda (f) (string-suffix? ".ss" f)) + (let ([entries (directory-list dir)]) + (if (list? entries) entries '()))))) + dirs)))) + (def (load-plugin path) + "Load a single plugin file." + (log-info logger "loading" `((path . ,path))) + (try (load path) + (set! *loaded-plugins* (cons path *loaded-plugins*)) + (log-info logger "loaded" `((path . ,path))) #t + (catch + (e) + (log-error + logger + "load-failed" + `((path . ,path) (error . ,(err->string e)))) + #f))) + (def (list-plugins) + "Return list of loaded plugin paths." + (reverse *loaded-plugins*)) + (def (init-plugins) + "Discover and load all plugins from configured directories." + (let ([files (find-plugins)]) + (unless (null? files) + (log-info logger "found" `((count . ,(length files)))) + (for-each load-plugin files))))) new file mode 100644 --- /dev/null +++ b/lib/jcode/mcp/client.sls @@ -0,0 +1,199 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/jcode/mcp/client.ss + +(library (jcode mcp client) + (export init-mcp-tools mcp-conn? mcp-conn-name mcp-start + mcp-initialize mcp-list-tools mcp-call-tool mcp-stop! + mcp-stop-all!) + (import + (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- + getenv path-extension path-absolute? thread? make-mutex + mutex? mutex-name) + (std text json) (std misc string) (jcode core log) + (jcode core config) (jcode tool registry) (jerboa core) + (jerboa runtime)) + (def logger (make-logger "mcp")) + (defstruct + mcp-conn + (name to-stdin from-stdout from-stderr pid next-id)) + (def *mcp-servers* '()) + (def (mcp-start name command args) + "Start an MCP server subprocess and return an mcp-conn." + (log-info + logger + "starting" + `((name . ,name) (command . ,command))) + (let ([cmd-str (string-join (cons command args) " ")]) + (let-values ([(to-stdin from-stdout from-stderr pid) + (open-process-ports + cmd-str + 'block + (make-transcoder (utf-8-codec)))]) + (let ([conn (make-mcp-conn name to-stdin from-stdout + from-stderr pid 1)]) + (set! *mcp-servers* (cons conn *mcp-servers*)) + conn)))) + (def (mcp-stop! conn) "Stop an MCP server." + (log-info + logger + "stopping" + `((name . ,(mcp-conn-name conn)))) + (try (close-port (mcp-conn-to-stdin conn)) + (catch (e) (void))) + (try (close-port (mcp-conn-from-stdout conn)) + (catch (e) (void))) + (try (close-port (mcp-conn-from-stderr conn)) + (catch (e) (void)))) + (def (mcp-stop-all!) + (for-each mcp-stop! *mcp-servers*) + (set! *mcp-servers* '())) + (def (mcp-next-id! conn) + (let ([id (mcp-conn-next-id conn)]) + (mcp-conn-next-id-set! conn (+ id 1)) + id)) + (def (mcp-send! conn method params) + "Send a JSON-RPC request and return the result." + (let* ([id (mcp-next-id! conn)] [msg (make-hash-table)]) + (hash-put! msg "jsonrpc" "2.0") + (hash-put! msg "id" id) + (hash-put! msg "method" method) + (hash-put! msg "params" (or params (make-hash-table))) + (let ([json-str (json-object->string msg)]) + (log-debug logger "send" `((method . ,method) (id . ,id))) + (display json-str (mcp-conn-to-stdin conn)) + (newline (mcp-conn-to-stdin conn)) + (flush-output-port (mcp-conn-to-stdin conn)) + (mcp-read-response conn id)))) + (def (mcp-notify! conn method params) + "Send a JSON-RPC notification (no id, no response expected)." + (let ([msg (make-hash-table)]) + (hash-put! msg "jsonrpc" "2.0") + (hash-put! msg "method" method) + (hash-put! msg "params" (or params (make-hash-table))) + (let ([json-str (json-object->string msg)]) + (display json-str (mcp-conn-to-stdin conn)) + (newline (mcp-conn-to-stdin conn)) + (flush-output-port (mcp-conn-to-stdin conn))))) + (def (mcp-read-response conn expected-id) + "Read lines from stdout until we get a response matching expected-id." + (let loop () + (let ([line (get-line (mcp-conn-from-stdout conn))]) + (cond + [(eof-object? line) + (error 'mcp + "Server closed connection" + (mcp-conn-name conn))] + [(string=? (string-trim line) "") (loop)] + [#t + (let ([msg (try (string->json-object line) (catch (e) #f))]) + (cond + [(not msg) (loop)] + [(hash-get msg "id") + (if (equal? (hash-get msg "id") expected-id) + (cond + [(hash-get msg "error") + (let ([err (hash-get msg "error")]) + (error 'mcp + (format + "~a: ~a" + (or (hash-get err "code") "?") + (or (hash-get err "message") + "unknown error"))))] + [#t (hash-get msg "result")]) + (loop))] + [#t (loop)]))])))) + (def (mcp-initialize conn) + "Perform MCP initialization handshake." + (let ([params (make-hash-table)] + [caps (make-hash-table)] + [client-info (make-hash-table)]) + (hash-put! client-info "name" "jcode") + (hash-put! client-info "version" "0.1.0") + (hash-put! params "protocolVersion" "2024-11-05") + (hash-put! params "capabilities" caps) + (hash-put! params "clientInfo" client-info) + (let ([result (mcp-send! conn "initialize" params)]) + (log-info + logger + "initialized" + `((server + . + ,(let ([si (hash-get result "serverInfo")]) + (if si (or (hash-get si "name") "?") "?"))))) + (mcp-notify! conn "notifications/initialized" #f) + result))) + (def (mcp-list-tools conn) + "Get list of tools from the server." + (let ([result (mcp-send! conn "tools/list" #f)]) + (or (hash-get result "tools") '()))) + (def (mcp-call-tool conn tool-name arguments) + "Call a tool on the server." + (let ([params (make-hash-table)]) + (hash-put! params "name" tool-name) + (hash-put! params "arguments" arguments) + (let ([result (mcp-send! conn "tools/call" params)]) + (let ([content (or (hash-get result "content") '())] + [is-error (hash-get result "isError")]) + (let ([text (string-join + (filter-map + (lambda (c) + (and (hash-table? c) + (equal? (hash-get c "type") "text") + (hash-get c "text"))) + content) + "\n")]) + (if is-error (string-append "MCP Error: " text) text)))))) + (def (register-mcp-tools conn prefix) + "Discover tools from MCP server and register them in jcode." + (let ([tools (mcp-list-tools conn)]) + (log-info + logger + "discovered" + `((server . ,(mcp-conn-name conn)) + (tools . ,(length tools)))) + (for-each + (lambda (tool) + (let ([name (hash-get tool "name")] + [desc (or (hash-get tool "description") "MCP tool")] + [schema (or (hash-get tool "inputSchema") + (make-hash-table))]) + (let ([jcode-name (string-append prefix name)]) + (register-tool! + jcode-name + desc + schema + (lambda (args) (mcp-call-tool conn name args)))))) + tools) + (length tools))) + (def (load-mcp-config) + "Load MCP server configurations. Returns alist of (name . config)." + (let ([servers (config-ref "mcpServers")]) + (if (and servers (hash-table? servers)) + (hash->list servers) + '()))) + (def (init-mcp-tools) + "Initialize all configured MCP servers." + (let ([configs (load-mcp-config)]) + (for-each + (lambda (pair) + (let ([name (car pair)] [cfg (cdr pair)]) + (try (let* ([command (hash-ref cfg "command" "node")] + [args (let ([a (hash-get cfg "args")]) + (if (list? a) a '()))] + [prefix (or (hash-get cfg "prefix") + (string-append "mcp_" name "_"))] + [conn (mcp-start name command args)]) + (mcp-initialize conn) + (let ([count (register-mcp-tools conn prefix)]) + (log-info + logger + "ready" + `((server . ,name) (tools . ,count))))) + (catch + (e) + (log-error + logger + "init-failed" + `((server . ,name) (error . ,(err->string e)))))))) + configs)))) new file mode 100644 --- /dev/null +++ b/lib/jcode/tool/lsp.sls @@ -0,0 +1,280 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/jcode/tool/lsp.ss + +(library (jcode tool lsp) + (export init-lsp-tools lsp-stop!) + (import + (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- + getenv path-extension path-absolute? thread? make-mutex + mutex? mutex-name) + (std text json) (std misc string) (jcode core log) + (jcode core config) (jcode tool registry) (jerboa core) + (jerboa runtime)) + (def logger (make-logger "lsp")) + (defstruct + lsp-conn + (to-stdin from-stdout from-stderr pid next-id root-uri)) + (def *lsp-conn* #f) + (def (lsp-start command args root-path) + "Start an LSP server subprocess." + (log-info logger "starting" `((command . ,command))) + (let ([cmd-str (string-join (cons command args) " ")]) + (let-values ([(to-stdin from-stdout from-stderr pid) + (open-process-ports + cmd-str + 'block + (make-transcoder (utf-8-codec)))]) + (let ([conn (make-lsp-conn to-stdin from-stdout from-stderr pid 1 + (string-append "file://" root-path))]) + (set! *lsp-conn* conn) + conn)))) + (def (lsp-stop! . args) + (when *lsp-conn* + (try (lsp-request *lsp-conn* "shutdown" (make-hash-table)) + (lsp-notify! *lsp-conn* "exit" (make-hash-table)) + (catch (e) (void))) + (try (close-port (lsp-conn-to-stdin *lsp-conn*)) + (catch (e) (void))) + (try (close-port (lsp-conn-from-stdout *lsp-conn*)) + (catch (e) (void))) + (try (close-port (lsp-conn-from-stderr *lsp-conn*)) + (catch (e) (void))) + (set! *lsp-conn* #f))) + (def (lsp-write! conn json-str) + "Write an LSP message with Content-Length header." + (let ([bytes (string->utf8 json-str)]) + (fprintf + (lsp-conn-to-stdin conn) + "Content-Length: ~a\r\n\r\n" + (bytevector-length bytes)) + (display json-str (lsp-conn-to-stdin conn)) + (flush-output-port (lsp-conn-to-stdin conn)))) + (def (lsp-read conn) + "Read an LSP message with Content-Length header." + (let ([port (lsp-conn-from-stdout conn)]) + (let header-loop ([content-length #f]) + (let ([line (get-line port)]) + (cond + [(eof-object? line) (error 'lsp "Server closed connection")] + [(or (string=? line "") (string=? line "\r")) + (unless content-length + (error 'lsp "Missing Content-Length header")) + (let ([buf (make-string content-length)]) + (let read-loop ([pos 0]) + (when (< pos content-length) + (let ([ch (read-char port)]) + (unless (eof-object? ch) + (string-set! buf pos ch) + (read-loop (+ pos 1)))))) + (string->json-object buf))] + [#t + (let ([trimmed (string-trim line)]) + (if (string-prefix? "Content-Length:" trimmed) + (let ([val (string-trim + (substring + trimmed + 15 + (string-length trimmed)))]) + (header-loop (string->number val))) + (header-loop content-length)))]))))) + (def (lsp-next-id! conn) + (let ([id (lsp-conn-next-id conn)]) + (lsp-conn-next-id-set! conn (+ id 1)) + id)) + (def (lsp-request conn method params) + "Send a JSON-RPC request and wait for response." + (let* ([id (lsp-next-id! conn)] [msg (make-hash-table)]) + (hash-put! msg "jsonrpc" "2.0") + (hash-put! msg "id" id) + (hash-put! msg "method" method) + (hash-put! msg "params" params) + (log-debug + logger + "request" + `((method . ,method) (id . ,id))) + (lsp-write! conn (json-object->string msg)) + (let loop () + (let ([resp (lsp-read conn)]) + (cond + [(equal? (hash-get resp "id") id) + (if (hash-get resp "error") + (let ([err (hash-get resp "error")]) + (error 'lsp + (format + "~a: ~a" + (or (hash-get err "code") "?") + (or (hash-get err "message") "error")))) + (hash-get resp "result"))] + [#t (loop)]))))) + (def (lsp-notify! conn method params) + "Send a notification (no response expected)." + (let ([msg (make-hash-table)]) + (hash-put! msg "jsonrpc" "2.0") + (hash-put! msg "method" method) + (hash-put! msg "params" params) + (lsp-write! conn (json-object->string msg)))) + (def (lsp-initialize conn) + "Send initialize request." + (let ([params (make-hash-table)] + [caps (make-hash-table)] + [client-info (make-hash-table)]) + (hash-put! client-info "name" "jcode") + (hash-put! client-info "version" "0.1.0") + (hash-put! params "processId" #f) + (hash-put! params "rootUri" (lsp-conn-root-uri conn)) + (hash-put! params "capabilities" caps) + (hash-put! params "clientInfo" client-info) + (let ([result (lsp-request conn "initialize" params)]) + (lsp-notify! conn "initialized" (make-hash-table)) + (log-info + logger + "initialized" + `((server + . + ,(let ([si (hash-get result "serverInfo")]) + (if si (or (hash-get si "name") "?") "?"))))) + result))) + (def (make-text-doc-pos uri line char) + (let ([params (make-hash-table)] + [td (make-hash-table)] + [pos (make-hash-table)]) + (hash-put! td "uri" uri) + (hash-put! pos "line" line) + (hash-put! pos "character" char) + (hash-put! params "textDocument" td) + (hash-put! params "position" pos) + params)) + (def (format-location loc) + "Format an LSP Location as file:line." + (if (hash-table? loc) + (let ([uri (or (hash-get loc "uri") "?")] + [range (hash-get loc "range")]) + (let ([line (if (and range (hash-get range "start")) + (+ 1 + (hash-get (hash-get range "start") "line")) + "?")]) + (format + "~a:~a" + (if (string-prefix? "file://" uri) + (substring uri 7 (string-length uri)) + uri) + line))) + (format "~a" loc))) + (def (handle-lsp-definition args) + (unless *lsp-conn* (error 'lsp "No LSP server connected")) + (let* ([file (hash-ref args "file" #f)] + [line (hash-ref args "line" 1)] + [char (hash-ref args "character" 0)] + [uri (if (string-prefix? "file://" file) + file + (string-append "file://" file))] + [params (make-text-doc-pos uri (- line 1) char)] + [result (lsp-request + *lsp-conn* + "textDocument/definition" + params)]) + (cond + [(not result) "No definition found."] + [(list? result) + (string-join (map format-location result) "\n")] + [(hash-table? result) (format-location result)] + [#t (format "~a" result)]))) + (def (handle-lsp-hover args) + (unless *lsp-conn* (error 'lsp "No LSP server connected")) + (let* ([file (hash-ref args "file" #f)] + [line (hash-ref args "line" 1)] + [char (hash-ref args "character" 0)] + [uri (if (string-prefix? "file://" file) + file + (string-append "file://" file))] + [params (make-text-doc-pos uri (- line 1) char)] + [result (lsp-request + *lsp-conn* + "textDocument/hover" + params)]) + (if (and result (hash-table? result)) + (let ([contents (hash-get result "contents")]) + (cond + [(string? contents) contents] + [(hash-table? contents) + (or (hash-get contents "value") "")] + [#t (format "~a" contents)])) + "No hover information."))) + (def (handle-lsp-references args) + (unless *lsp-conn* (error 'lsp "No LSP server connected")) + (let* ([file (hash-ref args "file" #f)] + [line (hash-ref args "line" 1)] + [char (hash-ref args "character" 0)] + [uri (if (string-prefix? "file://" file) + file + (string-append "file://" file))] + [params (make-text-doc-pos uri (- line 1) char)] + [ctx (make-hash-table)]) + (hash-put! ctx "includeDeclaration" #t) + (hash-put! params "context" ctx) + (let ([result (lsp-request + *lsp-conn* + "textDocument/references" + params)]) + (if (and result (list? result)) + (string-join (map format-location result) "\n") + "No references found.")))) + (def (make-lsp-schema) + (let ([schema (make-hash-table)] + [props (make-hash-table)] + [file-p (make-hash-table)] + [line-p (make-hash-table)] + [char-p (make-hash-table)]) + (hash-put! file-p "type" "string") + (hash-put! file-p "description" "Absolute file path") + (hash-put! line-p "type" "number") + (hash-put! line-p "description" "Line number (1-based)") + (hash-put! char-p "type" "number") + (hash-put! + char-p + "description" + "Character offset (0-based)") + (hash-put! props "file" file-p) + (hash-put! props "line" line-p) + (hash-put! props "character" char-p) + (hash-put! schema "type" "object") + (hash-put! schema "properties" props) + (hash-put! schema "required" '("file" "line")) + schema)) + (def (init-lsp-tools) + "Start LSP server if configured and register tools." + (let ([lsp-cfg (config-ref "lsp")]) + (when (and lsp-cfg (hash-table? lsp-cfg)) + (let ([command (hash-ref lsp-cfg "command" #f)] + [args (or (hash-get lsp-cfg "args") '())] + [root (or (hash-get lsp-cfg "root") (current-directory))]) + (when command + (try (let ([conn (lsp-start + command + (if (list? args) args '()) + root)]) + (lsp-initialize conn) + (let ([schema (make-lsp-schema)]) + (register-tool! + "lsp_definition" + "Go to definition of symbol at file:line:character" + schema + handle-lsp-definition) + (register-tool! + "lsp_hover" + "Get hover information (type, docs) for symbol at file:line:character" + schema + handle-lsp-hover) + (register-tool! + "lsp_references" + "Find all references to symbol at file:line:character" + schema + handle-lsp-references)) + (log-info logger "ready" `((tools . 3)))) + (catch + (e) + (log-error + logger + "init-failed" + `((error . ,(err->string e)))))))))))) --- a/lib/jcode/ui/cli.sls +++ b/lib/jcode/ui/cli.sls @@ -12,7 +12,8 @@ (jcode core log) (jcode core session) (jcode core message) (jcode core agent) (jcode tool registry) (jcode tool file) (jcode tool bash) (jcode tool web) (jcode tool batch) - (jcode tool git) (jerboa core) (jerboa runtime)) + (jcode tool git) (jcode mcp client) (jcode tool lsp) + (jcode core plugin) (jerboa core) (jerboa runtime)) (def logger (make-logger "cli")) (def *version* "0.1.0") (def (cli-main args) @@ -76,7 +77,8 @@ (cons (cons '\x2D;-provider (cadr args)) opts))] [else (cons (cons '\x2D;- args) (reverse opts))]))) (def (init-tools) (init-file-tools) (init-bash-tool) - (init-web-tools) (init-batch-tool) (init-git-tools)) + (init-web-tools) (init-batch-tool) (init-git-tools) + (init-mcp-tools) (init-lsp-tools) (init-plugins)) (def (display-help) (display "jcode - Portable AI coding agent\n\nUSAGE:\n jcode [OPTIONS] [PROMPT]\n jcode [COMMAND]\n\nOPTIONS:\n -h, --help Show this help message\n -v, --version Show version\n -d, --debug Enable debug logging\n -m, --model Model to use (default: claude-sonnet-4-20250514)\n -p, --provider Provider to use (default: anthropic)\n\nCOMMANDS:\n session list List all sessions\n session resume Resume a previous session\n config Show or edit configuration\n\nEXAMPLES:\n jcode Start interactive session\n jcode \"Read main.ss\" One-shot query\n jcode session list List sessions\n")) @@ -205,6 +207,11 @@ [(equal? cmd "compact") (let ([msgs (session-get-messages session-id)]) (printf "Messages in session: ~a~n" (length msgs)))] + [(equal? cmd "plugins") + (let ([plugins (list-plugins)]) + (if (null? plugins) + (printf "No plugins loaded.~n") + (for-each (lambda (p) (printf " ~a~n" p)) plugins)))] [(or (equal? cmd "quit") (equal? cmd "exit")) (printf "Goodbye!~n") (exit 0)] new file mode 100644 --- /dev/null +++ b/src/jcode/core/plugin.ss @@ -0,0 +1,64 @@ +;;; jcode plugin system +;;; Loads .ss plugin files at runtime, compiling and evaluating them +;;; in the interaction environment. Plugins can register tools, add +;;; providers, or extend jcode in any way. + +(export init-plugins + load-plugin + list-plugins) + +(import :std/misc/string + :jcode/core/log + :jcode/core/config) + +(def logger (make-logger "plugin")) + +(def *loaded-plugins* '()) + +(def (plugin-dirs) + "Return list of directories to scan for plugins." + (let ((home-dir (path-join (or (getenv "XDG_CONFIG_HOME") + (path-join (getenv "HOME") ".config")) + "jcode" "plugins")) + (local-dir (path-join (current-directory) ".jcode" "plugins")) + (cfg-dirs (config-ref "pluginDirs"))) + (filter file-directory? + (append + (if (and cfg-dirs (list? cfg-dirs)) cfg-dirs '()) + (list home-dir local-dir))))) + +(def (find-plugins) + "Find all .ss files in plugin directories." + (let ((dirs (plugin-dirs))) + (apply append + (map + (lambda (dir) + (map (lambda (f) (path-join dir f)) + (filter (lambda (f) (string-suffix? ".ss" f)) + (let ((entries (directory-list dir))) + (if (list? entries) entries '()))))) + dirs)))) + +(def (load-plugin path) + "Load a single plugin file." + (log-info logger "loading" `((path . ,path))) + (try + (load path) + (set! *loaded-plugins* (cons path *loaded-plugins*)) + (log-info logger "loaded" `((path . ,path))) + #t + (catch (e) + (log-error logger "load-failed" + `((path . ,path) (error . ,(err->string e)))) + #f))) + +(def (list-plugins) + "Return list of loaded plugin paths." + (reverse *loaded-plugins*)) + +(def (init-plugins) + "Discover and load all plugins from configured directories." + (let ((files (find-plugins))) + (unless (null? files) + (log-info logger "found" `((count . ,(length files)))) + (for-each load-plugin files)))) new file mode 100644 --- /dev/null +++ b/src/jcode/mcp/client.ss @@ -0,0 +1,213 @@ +;;; MCP (Model Context Protocol) client +;;; Connects to MCP servers via stdio transport, discovers tools, +;;; and registers them in the jcode tool registry. + +(export init-mcp-tools + mcp-conn? + mcp-conn-name + mcp-start + mcp-initialize + mcp-list-tools + mcp-call-tool + mcp-stop! + mcp-stop-all!) + +(import :std/text/json + :std/misc/string + :jcode/core/log + :jcode/core/config + :jcode/tool/registry) + +(def logger (make-logger "mcp")) + +;; --- MCP server state --- + +(defstruct mcp-conn (name to-stdin from-stdout from-stderr pid next-id)) + +(def *mcp-servers* '()) + +;; --- subprocess management --- + +(def (mcp-start name command args) + "Start an MCP server subprocess and return an mcp-conn." + (log-info logger "starting" `((name . ,name) (command . ,command))) + (let ((cmd-str (string-join (cons command args) " "))) + (let-values (((to-stdin from-stdout from-stderr pid) + (open-process-ports cmd-str 'block (make-transcoder (utf-8-codec))))) + (let ((conn (make-mcp-conn name to-stdin from-stdout from-stderr pid 1))) + (set! *mcp-servers* (cons conn *mcp-servers*)) + conn)))) + +(def (mcp-stop! conn) + "Stop an MCP server." + (log-info logger "stopping" `((name . ,(mcp-conn-name conn)))) + (try + (close-port (mcp-conn-to-stdin conn)) + (catch (e) (void))) + (try + (close-port (mcp-conn-from-stdout conn)) + (catch (e) (void))) + (try + (close-port (mcp-conn-from-stderr conn)) + (catch (e) (void)))) + +(def (mcp-stop-all!) + (for-each mcp-stop! *mcp-servers*) + (set! *mcp-servers* '())) + +;; --- JSON-RPC 2.0 protocol --- + +(def (mcp-next-id! conn) + (let ((id (mcp-conn-next-id conn))) + (mcp-conn-next-id-set! conn (+ id 1)) + id)) + +(def (mcp-send! conn method params) + "Send a JSON-RPC request and return the result." + (let* ((id (mcp-next-id! conn)) + (msg (make-hash-table))) + (hash-put! msg "jsonrpc" "2.0") + (hash-put! msg "id" id) + (hash-put! msg "method" method) + (hash-put! msg "params" (or params (make-hash-table))) + (let ((json-str (json-object->string msg))) + (log-debug logger "send" `((method . ,method) (id . ,id))) + (display json-str (mcp-conn-to-stdin conn)) + (newline (mcp-conn-to-stdin conn)) + (flush-output-port (mcp-conn-to-stdin conn)) + (mcp-read-response conn id)))) + +(def (mcp-notify! conn method params) + "Send a JSON-RPC notification (no id, no response expected)." + (let ((msg (make-hash-table))) + (hash-put! msg "jsonrpc" "2.0") + (hash-put! msg "method" method) + (hash-put! msg "params" (or params (make-hash-table))) + (let ((json-str (json-object->string msg))) + (display json-str (mcp-conn-to-stdin conn)) + (newline (mcp-conn-to-stdin conn)) + (flush-output-port (mcp-conn-to-stdin conn))))) + +(def (mcp-read-response conn expected-id) + "Read lines from stdout until we get a response matching expected-id." + (let loop () + (let ((line (get-line (mcp-conn-from-stdout conn)))) + (cond + ((eof-object? line) + (error 'mcp "Server closed connection" (mcp-conn-name conn))) + ((string=? (string-trim line) "") + (loop)) ;; skip blank lines + (#t + (let ((msg (try (string->json-object line) (catch (e) #f)))) + (cond + ((not msg) (loop)) ;; skip non-JSON lines (stderr leakage) + ((hash-get msg "id") + ;; Response message + (if (equal? (hash-get msg "id") expected-id) + (cond + ((hash-get msg "error") + (let ((err (hash-get msg "error"))) + (error 'mcp + (format "~a: ~a" + (or (hash-get err "code") "?") + (or (hash-get err "message") "unknown error"))))) + (#t (hash-get msg "result"))) + (loop))) ;; wrong id, keep reading + (#t (loop))))))))) ;; notification, skip + +;; --- MCP protocol operations --- + +(def (mcp-initialize conn) + "Perform MCP initialization handshake." + (let ((params (make-hash-table)) + (caps (make-hash-table)) + (client-info (make-hash-table))) + (hash-put! client-info "name" "jcode") + (hash-put! client-info "version" "0.1.0") + (hash-put! params "protocolVersion" "2024-11-05") + (hash-put! params "capabilities" caps) + (hash-put! params "clientInfo" client-info) + (let ((result (mcp-send! conn "initialize" params))) + (log-info logger "initialized" + `((server . ,(let ((si (hash-get result "serverInfo"))) + (if si (or (hash-get si "name") "?") "?"))))) + ;; Send initialized notification + (mcp-notify! conn "notifications/initialized" #f) + result))) + +(def (mcp-list-tools conn) + "Get list of tools from the server." + (let ((result (mcp-send! conn "tools/list" #f))) + (or (hash-get result "tools") '()))) + +(def (mcp-call-tool conn tool-name arguments) + "Call a tool on the server." + (let ((params (make-hash-table))) + (hash-put! params "name" tool-name) + (hash-put! params "arguments" arguments) + (let ((result (mcp-send! conn "tools/call" params))) + ;; Extract text content from result + (let ((content (or (hash-get result "content") '())) + (is-error (hash-get result "isError"))) + (let ((text (string-join + (filter-map + (lambda (c) + (and (hash-table? c) + (equal? (hash-get c "type") "text") + (hash-get c "text"))) + content) + "\n"))) + (if is-error + (string-append "MCP Error: " text) + text)))))) + +;; --- tool registration --- + +(def (register-mcp-tools conn prefix) + "Discover tools from MCP server and register them in jcode." + (let ((tools (mcp-list-tools conn))) + (log-info logger "discovered" + `((server . ,(mcp-conn-name conn)) (tools . ,(length tools)))) + (for-each + (lambda (tool) + (let ((name (hash-get tool "name")) + (desc (or (hash-get tool "description") "MCP tool")) + (schema (or (hash-get tool "inputSchema") (make-hash-table)))) + (let ((jcode-name (string-append prefix name))) + (register-tool! jcode-name desc schema + (lambda (args) + (mcp-call-tool conn name args)))))) + tools) + (length tools))) + +;; --- config and init --- + +(def (load-mcp-config) + "Load MCP server configurations. Returns alist of (name . config)." + (let ((servers (config-ref "mcpServers"))) + (if (and servers (hash-table? servers)) + (hash->list servers) + '()))) + +(def (init-mcp-tools) + "Initialize all configured MCP servers." + (let ((configs (load-mcp-config))) + (for-each + (lambda (pair) + (let ((name (car pair)) + (cfg (cdr pair))) + (try + (let* ((command (hash-ref cfg "command" "node")) + (args (let ((a (hash-get cfg "args"))) + (if (list? a) a '()))) + (prefix (or (hash-get cfg "prefix") + (string-append "mcp_" name "_"))) + (conn (mcp-start name command args))) + (mcp-initialize conn) + (let ((count (register-mcp-tools conn prefix))) + (log-info logger "ready" + `((server . ,name) (tools . ,count))))) + (catch (e) + (log-error logger "init-failed" + `((server . ,name) (error . ,(err->string e)))))))) + configs))) new file mode 100644 --- /dev/null +++ b/src/jcode/tool/lsp.ss @@ -0,0 +1,268 @@ +;;; jcode LSP client +;;; Connects to an LSP server via stdio with Content-Length framing. +;;; Registers definition, hover, and references as tools. + +(export init-lsp-tools + lsp-stop!) + +(import :std/text/json + :std/misc/string + :jcode/core/log + :jcode/core/config + :jcode/tool/registry) + +(def logger (make-logger "lsp")) + +;; --- LSP connection state --- + +(defstruct lsp-conn (to-stdin from-stdout from-stderr pid next-id root-uri)) + +(def *lsp-conn* #f) + +;; --- subprocess management --- + +(def (lsp-start command args root-path) + "Start an LSP server subprocess." + (log-info logger "starting" `((command . ,command))) + (let ((cmd-str (string-join (cons command args) " "))) + (let-values (((to-stdin from-stdout from-stderr pid) + (open-process-ports cmd-str 'block (make-transcoder (utf-8-codec))))) + (let ((conn (make-lsp-conn to-stdin from-stdout from-stderr pid 1 + (string-append "file://" root-path)))) + (set! *lsp-conn* conn) + conn)))) + +(def (lsp-stop! . args) + (when *lsp-conn* + (try + (lsp-request *lsp-conn* "shutdown" (make-hash-table)) + (lsp-notify! *lsp-conn* "exit" (make-hash-table)) + (catch (e) (void))) + (try (close-port (lsp-conn-to-stdin *lsp-conn*)) (catch (e) (void))) + (try (close-port (lsp-conn-from-stdout *lsp-conn*)) (catch (e) (void))) + (try (close-port (lsp-conn-from-stderr *lsp-conn*)) (catch (e) (void))) + (set! *lsp-conn* #f))) + +;; --- Content-Length framing --- + +(def (lsp-write! conn json-str) + "Write an LSP message with Content-Length header." + (let ((bytes (string->utf8 json-str))) + (fprintf (lsp-conn-to-stdin conn) "Content-Length: ~a\r\n\r\n" (bytevector-length bytes)) + (display json-str (lsp-conn-to-stdin conn)) + (flush-output-port (lsp-conn-to-stdin conn)))) + +(def (lsp-read conn) + "Read an LSP message with Content-Length header." + (let ((port (lsp-conn-from-stdout conn))) + ;; Read headers until blank line + (let header-loop ((content-length #f)) + (let ((line (get-line port))) + (cond + ((eof-object? line) (error 'lsp "Server closed connection")) + ((or (string=? line "") (string=? line "\r")) + ;; End of headers + (unless content-length + (error 'lsp "Missing Content-Length header")) + ;; Read exactly content-length bytes + (let ((buf (make-string content-length))) + (let read-loop ((pos 0)) + (when (< pos content-length) + (let ((ch (read-char port))) + (unless (eof-object? ch) + (string-set! buf pos ch) + (read-loop (+ pos 1)))))) + (string->json-object buf))) + (#t + ;; Parse header + (let ((trimmed (string-trim line))) + (if (string-prefix? "Content-Length:" trimmed) + (let ((val (string-trim (substring trimmed 15 (string-length trimmed))))) + (header-loop (string->number val))) + (header-loop content-length))))))))) + +;; --- JSON-RPC --- + +(def (lsp-next-id! conn) + (let ((id (lsp-conn-next-id conn))) + (lsp-conn-next-id-set! conn (+ id 1)) + id)) + +(def (lsp-request conn method params) + "Send a JSON-RPC request and wait for response." + (let* ((id (lsp-next-id! conn)) + (msg (make-hash-table))) + (hash-put! msg "jsonrpc" "2.0") + (hash-put! msg "id" id) + (hash-put! msg "method" method) + (hash-put! msg "params" params) + (log-debug logger "request" `((method . ,method) (id . ,id))) + (lsp-write! conn (json-object->string msg)) + ;; Read responses until we get matching id + (let loop () + (let ((resp (lsp-read conn))) + (cond + ((equal? (hash-get resp "id") id) + (if (hash-get resp "error") + (let ((err (hash-get resp "error"))) + (error 'lsp (format "~a: ~a" + (or (hash-get err "code") "?") + (or (hash-get err "message") "error")))) + (hash-get resp "result"))) + (#t (loop))))))) ;; notification or wrong id, skip + +(def (lsp-notify! conn method params) + "Send a notification (no response expected)." + (let ((msg (make-hash-table))) + (hash-put! msg "jsonrpc" "2.0") + (hash-put! msg "method" method) + (hash-put! msg "params" params) + (lsp-write! conn (json-object->string msg)))) + +;; --- LSP protocol --- + +(def (lsp-initialize conn) + "Send initialize request." + (let ((params (make-hash-table)) + (caps (make-hash-table)) + (client-info (make-hash-table))) + (hash-put! client-info "name" "jcode") + (hash-put! client-info "version" "0.1.0") + (hash-put! params "processId" #f) + (hash-put! params "rootUri" (lsp-conn-root-uri conn)) + (hash-put! params "capabilities" caps)