system-manager-wakasu
1;;; mcp.el --- Model Context Protocol -*- lexical-binding: t; -*-
2
3;; Copyright (C) 2025 lizqwer scott
4
5;; Author: lizqwer scott <lizqwerscott@gmail.com>
6;; Version: 0.1.0
7;; Package-Requires: ((emacs "30.1") (jsonrpc "1.0.25"))
8;; Keywords: ai, mcp
9;; URL: https://github.com/lizqwerscott/mcp.el
10
11;; This program is free software; you can redistribute it and/or modify
12;; it under the terms of the GNU General Public License as published by
13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
15
16;; This program is distributed in the hope that it will be useful,
17;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;; GNU General Public License for more details.
20
21;; You should have received a copy of the GNU General Public License
22;; along with this program. If not, see <https://www.gnu.org/licenses/>.
23
24;;; Commentary:
25
26;;
27
28;;; Code:
29
30(require 'jsonrpc)
31(require 'cl-lib)
32(require 'url)
33
34(defconst *MCP-VERSION* "2024-11-05"
35 "MCP support version.")
36
37(defcustom mcp-server-start-time 60
38 "The Seconds of mcp server start time."
39 :group 'mcp
40 :type 'integer)
41
42(defcustom mcp-server-wait-initial-time 2
43 "Seconds to wait after server init before fetching MCP resources.
44
45This delay is applied after server initialization completes, but
46before requesting tools, prompts and resources. Gives the server
47time to fully initialize all components before handling requests."
48 :group 'mcp
49 :type 'integer)
50
51(defcustom mcp-log-level 'info
52 "The min log level for mcp server.
53Available levels:
54- debug: Detailed debugging information (function entry/exit points)
55- info: General informational messages (operation progress updates)
56- notice: Normal but significant events (configuration changes)
57- warning: Warning conditions (deprecated feature usage)
58- error: Error conditions (operation failures)
59- critical: Critical conditions (system component failures)
60- alert: Action must be taken immediately (data corruption detected)
61- emergency: System is unusable (complete system failure)"
62 :group 'mcp
63 :type '(choice (const :tag "debug" debug)
64 (const :tag "info" info)
65 (const :tag "notice" notice)
66 (const :tag "warning" warning)
67 (const :tag "error" error)
68 (const :tag "critical" critical)
69 (const :tag "alert" alert)
70 (const :tag "emergency" emergency)))
71
72(defclass mcp-process-connection (jsonrpc-process-connection)
73 ((connection-type
74 :initarg :connection-type
75 :accessor mcp--connection-type)
76 (-status
77 :initform 'init
78 :accessor mcp--status)
79 (-capabilities
80 :initform nil
81 :accessor mcp--capabilities)
82 (-serverinfo
83 :initform nil
84 :accessor mcp--server-info)
85 (-prompts
86 :initform nil
87 :accessor mcp--prompts)
88 (-tools
89 :initform nil
90 :accessor mcp--tools)
91 (-resources
92 :initform nil
93 :accessor mcp--resources))
94 :documentation "A MCP connection over an Emacs process.")
95
96(defclass mcp-sse-process-connection (mcp-process-connection)
97 ((-host
98 :initarg :host
99 :accessor mcp--host)
100 (-port
101 :initarg :port
102 :accessor mcp--port)
103 (-tls
104 :initarg :tls
105 :accessor mcp--tls)
106 (-endpoint
107 :initform nil
108 :accessor mcp--endpoint))
109 :documentation "A sse MCP connection over an Emacs process.")
110
111(defclass mcp-stdio-process-connection (mcp-process-connection)
112 ()
113 :documentation "A stdio MCP connection over an Emacs process.")
114
115(cl-defmethod initialize-instance :after ((_ mcp-process-connection) slots)
116 "Init mcp process connection."
117 (cl-destructuring-bind (&key ((:process proc)) &allow-other-keys) slots
118 (set-process-filter proc #'mcp--process-filter)))
119
120(cl-defmethod jsonrpc-connection-send ((connection mcp-process-connection)
121 &rest args
122 &key
123 id
124 method
125 _params
126 (_result nil result-supplied-p)
127 error
128 _partial)
129 "Send JSON-RPC message to CONNECTION.
130CONNECTION is an MCP process connection instance. ARGS is a plist
131containing the message components:
132
133METHOD - Method name (string, symbol or keyword)
134PARAMS - Parameters for the method (optional)
135ID - Request ID (optional)
136RESULT - Response result (for replies)
137error - Error object (for error replies)
138partial - Partial response flag (optional)
139
140For requests, both :method and :id should be provided.
141For notifications, only :method is required.
142For replies, either :_result or :error should be provided.
143
144The message is sent differently based on connection type:
145- SSE connections use HTTP POST requests
146- Stdio connections write directly to the process"
147 (when method
148 ;; sanitize method into a string
149 (setq args
150 (plist-put args :method
151 (cond ((keywordp method) (substring (symbol-name method) 1))
152 ((symbolp method) (symbol-name method))
153 ((stringp method) method)
154 (t (error "[jsonrpc] invalid method %s" method))))))
155 (let* ((kind (cond ((or result-supplied-p error) 'reply)
156 (id 'request)
157 (method 'notification)))
158 (converted (jsonrpc-convert-to-endpoint connection args kind))
159 (json (jsonrpc--json-encode converted)))
160 (pcase (mcp--connection-type connection)
161 ('sse
162 (let ((url-request-method "POST")
163 (url-request-extra-headers
164 '(("Content-Type" . "application/json")))
165 (url-request-data (encode-coding-string
166 json
167 'utf-8))
168 (url (format "%s://%s:%s%s"
169 (if (mcp--tls connection) "https" "http")
170 (mcp--host connection)
171 (mcp--port connection)
172 (mcp--endpoint connection))))
173 (url-retrieve url
174 #'(lambda (_)
175 (when (buffer-live-p (current-buffer))
176 (goto-char (point-min))
177 ;; (when (search-forward "\n\n" nil t)
178 ;; (let* ((headers (buffer-substring (point-min) (point)))
179 ;; (body (buffer-substring (point) (point-max)))
180 ;; (response-code (string-match "HTTP/.* \\([0-9]+\\)" headers)))))
181 (kill-buffer))))))
182 ('stdio
183 (process-send-string
184 (jsonrpc--process connection)
185 (format "%s\r\n" json))))
186 (jsonrpc--event
187 connection
188 'client
189 :json json
190 :kind kind
191 :message args
192 :foreign-message converted)))
193
194(defvar mcp--in-process-filter nil
195 "Non-nil if inside `mcp--process-filter'.")
196
197(cl-defun mcp--process-filter (proc string)
198 "Called when new data STRING has arrived for PROC."
199 (when mcp--in-process-filter
200 ;; Problematic recursive process filters may happen if
201 ;; `jsonrpc-connection-receive', called by us, eventually calls
202 ;; client code which calls `process-send-string' (which see) to,
203 ;; say send a follow-up message. If that happens to writes enough
204 ;; bytes for pending output to be received, we will lose JSONRPC
205 ;; messages. In that case, remove recursiveness by re-scheduling
206 ;; ourselves to run from within a timer as soon as possible
207 ;; (bug#60088)
208 (run-at-time 0 nil #'mcp--process-filter proc string)
209 (cl-return-from mcp--process-filter))
210 (when (buffer-live-p (process-buffer proc))
211 (with-current-buffer (process-buffer proc)
212 (let* ((conn (process-get proc 'jsonrpc-connection))
213 (queue (or (process-get proc 'jsonrpc-mqueue) nil))
214 (buf (or (process-get proc 'jsonrpc-pending)
215 (plist-get (process-put
216 proc 'jsonrpc-pending
217 (generate-new-buffer " *mcp-jsonrpc-pending*"))
218 'jsonrpc-pending)))
219 (data (with-current-buffer buf
220 (goto-char (point-max))
221 (insert string)
222 (buffer-string)))
223 (type (mcp--connection-type conn))
224 (parsed-messages nil)
225 (lines (split-string data "\n"))
226 (parsed-index 0)
227 (endpoint-waitp nil)
228 (line-index 0))
229 (dolist (line lines)
230 (pcase type
231 ('sse
232 (cond
233 ((and (<= (+ line-index 1) (length lines))
234 (string-prefix-p "event:" (elt lines (+ line-index 1)))))
235 ((string-prefix-p "event: endpoint" line)
236 (setq endpoint-waitp t))
237 ((string-prefix-p "data: " line)
238 (let ((json-str (if (and endpoint-waitp
239 (string-match "http://[^/]+\\(/[^[:space:]]+\\)" line))
240 (match-string 1 line)
241 (string-trim (substring line 6)))))
242 (unless (string-empty-p json-str)
243 (if endpoint-waitp
244 (setf (mcp--endpoint conn) json-str)
245 (push (cons parsed-index json-str) parsed-messages)
246 (cl-incf parsed-index)))))
247 ((and (mcp--endpoint conn)
248 (not (or (string-prefix-p "2d" line)
249 (string-prefix-p ": ping" line)
250 (string-prefix-p "event: message" line)))
251 (not (with-current-buffer buf (= (point-min) (point-max)))))
252 (let ((json-str (string-trim line)))
253 (unless (string-empty-p json-str)
254 (push (cons parsed-index json-str) parsed-messages)
255 (cl-incf parsed-index))))))
256 ('stdio
257 (let ((json-str (string-trim line)))
258 (unless (string-empty-p json-str)
259 (push (cons parsed-index json-str) parsed-messages)
260 (cl-incf parsed-index)))))
261 (cl-incf line-index))
262 (setq parsed-messages (nreverse parsed-messages))
263
264 (with-current-buffer buf (erase-buffer))
265 ;; Add messages to MQUEUE
266 (dolist (msg parsed-messages)
267 (pcase-let ((`(,_index . ,json-str) msg))
268 (let ((json nil)
269 (json-str (with-current-buffer buf
270 (if (= (point-min) (point-max))
271 json-str
272 (goto-char (point-max))
273 (insert json-str)
274 (buffer-string)))))
275 (condition-case-unless-debug err
276 (setq json (json-parse-string json-str
277 :object-type 'plist
278 :null-object nil
279 :false-object :json-false))
280 (json-parse-error
281 ;; parse error and not because of incomplete json
282 (jsonrpc--warn "Invalid JSON: %s\t %s" (cdr err) json-str))
283 (json-end-of-file
284 ;; Save remaining data to pending for next processing
285 (with-current-buffer buf
286 (goto-char (point-max))
287 (insert json-str)
288 (process-put proc 'jsonrpc-pending buf))))
289 (when json
290 (with-current-buffer buf (erase-buffer))
291 (when (listp json)
292 (setq json (plist-put json :jsonrpc-json json-str))
293 (push json queue))))))
294
295 ;; Save updated queue
296 (process-put proc 'jsonrpc-mqueue queue)
297
298 ;; Dispatch messages in timer
299 (cl-loop with time = (current-time)
300 for msg = (pop queue) while msg
301 do (let ((timer (timer-create)))
302 (timer-set-time timer time)
303 (timer-set-function timer
304 (lambda (conn msg)
305 (with-temp-buffer
306 (jsonrpc-connection-receive conn msg)))
307 (list conn msg))
308 (timer-activate timer)))
309
310 ;; Save final queue (might have been consumed by timer pop)
311 (process-put proc 'jsonrpc-mqueue queue)))))
312
313(defun mcp--sse-connect (process host port path)
314 "Establish SSE connection to server.
315PROCESS is the network process object. HOST and PORT specify the
316server address. PATH is the endpoint path for SSE connection.
317Sends HTTP GET request with SSE headers to initiate the event
318stream connection. Used internally by MCP for SSE-based JSON-RPC
319communication."
320 (process-send-string process
321 (concat
322 (format "GET %s HTTP/1.1\r\n"
323 path)
324 (format "Host: %s:%s\r\n"
325 host
326 port)
327 "Accept: text/event-stream\r\n"
328 "Cache-Control: no-cache\r\n"
329 "Connection: keep-alive\r\n\r\n")))
330
331(cl-defun mcp-notify (connection method &optional (params nil))
332 "Send notification to CONNECTION without expecting response.
333METHOD is the notification name (string or symbol). PARAMS is an
334optional plist of parameters.
335This is a thin wrapper around =jsonrpc-connection-send' that
336omits the :id parameter to indicate it's a notification rather
337than a request."
338 (apply #'jsonrpc-connection-send
339 `(,connection
340 :method ,method
341 ,@(when params
342 (list :params params)))))
343
344(defvar mcp-server-connections (make-hash-table :test #'equal)
345 "Mcp server process.")
346
347(defun mcp-request-dispatcher (name method params)
348 "Default handler for MCP server requests.
349NAME identifies the server connection. METHOD is the requested
350method name. PARAMS contains the method parameters.
351
352This basic implementation just logs the request. Applications
353should override this to implement actual request handling."
354 (message "%s Received request: method=%s, params=%s" name method params))
355
356(defun mcp-notification-dispatcher (connection name method params)
357 "Handle notifications from MCP server.
358CONNECTION is the JSON-RPC connection object. NAME identifies the
359server. METHOD is the notification name. PARAMS contains the
360notification data."
361 (pcase method
362 ('notifications/message
363 (cond ((or (plist-member (mcp--capabilities connection) :logging)
364 (and (plist-member params :level)
365 (plist-member params :data)))
366 (cl-destructuring-bind (&key level data &allow-other-keys) params
367 (let ((logger (plist-get params :logger)))
368 (message "[mcp][%s][%s]%s: %s"
369 name
370 level
371 (if logger
372 (format "[%s]" logger)
373 "")
374 data))))))
375 (_
376 (message "%s Received notification: method=%s, params=%s" name method params))))
377
378(defun mcp-on-shutdown (name)
379 "When NAME mcp server shutdown."
380 (message "%s connection shutdown" name))
381
382(defun mcp--parse-http-url (url)
383 "Parse HTTP/HTTPS URL into connection components.
384URL should be a string in format http(s)://host[:port][/path].
385
386Returns a plist with connection parameters:
387:tls - Boolean indicating HTTPS (t) or HTTP (nil)
388:host - Server hostname (string)
389:port - Port number (integer, defaults to 80/443)
390:path - URL path component (string)
391
392Returns nil if URL is invalid or not HTTP/HTTPS."
393 (when-let* ((url (url-generic-parse-url url))
394 (type (url-type url))
395 (host (url-host url))
396 (filename (url-filename url)))
397 (when (or (string= type "http")
398 (string= type "https"))
399 (let ((port (url-port url))
400 (tls (string= "https" type)))
401 (list :tls tls
402 :host host
403 :port (if port
404 port
405 (if tls
406 443
407 80))
408 :path filename)))))
409
410;;;###autoload
411(cl-defun mcp-connect-server (name &key command args url env initial-callback
412 tools-callback prompts-callback
413 resources-callback error-callback)
414 "Connect to an MCP server with NAME, COMMAND, and ARGS or URL.
415
416NAME is a string representing the name of the server.
417COMMAND is a string representing the command to start the server
418in stdio mcp server.
419ARGS is a list of arguments to pass to the COMMAND.
420URL is a string arguments to connect sse mcp server.
421ENV is a plist argument to set mcp server env.
422
423INITIAL-CALLBACK is a function called when the server completes
424the connection.
425TOOLS-CALLBACK is a function called to handle the list of tools
426provided by the server.
427PROMPTS-CALLBACK is a function called to handle the list of prompts
428provided by the server.
429RESOURCES-CALLBACK is a function called to handle the list of
430resources provided by the server.
431ERROR-CALLBACK is a function to call on error.
432
433This function creates a new process for the server, initializes a connection,
434and sends an initialization message to the server. The connection is stored
435in the `mcp-server-connections` hash table for future reference."
436 (unless (gethash name mcp-server-connections)
437 (when-let* ((server-config (cond (command
438 (list :connection-type 'stdio
439 :command command
440 :args args))
441 (url
442 (when-let* ((res (mcp--parse-http-url url)))
443 (plist-put res
444 :connection-type 'sse)))))
445 (connection-type (plist-get server-config :connection-type))
446 (buffer-name (format "*Mcp %s server*" name))
447 (process-name (format "mcp-%s-server" name))
448 (process (pcase connection-type
449 ('sse
450 (get-buffer-create buffer-name)
451 (open-network-stream process-name
452 buffer-name
453 (plist-get server-config :host)
454 (plist-get server-config :port)
455 :type (if (plist-get server-config :tls)
456 'tls
457 'network)))
458 ('stdio
459 (let ((env (mapcar #'(lambda (item)
460 (pcase-let* ((`(,key ,value) item))
461 (let ((key (symbol-name key)))
462 (list (substring key 1)
463 (format "%s" value)))))
464 (seq-partition env 2)))
465 (process-environment (copy-sequence process-environment)))
466 (when env
467 (dolist (elem env)
468 (setenv (car elem) (cadr elem))))
469 (make-process
470 :name name
471 :command (append (list command)
472 (plist-get server-config :args))
473 :connection-type 'pipe
474 :coding 'utf-8-emacs-unix
475 ;; :noquery t
476 :stderr (get-buffer-create
477 (format "*%s stderr*" name))
478 ;; :file-handler t
479 ))))))
480 (when (equal connection-type 'sse)
481 (mcp--sse-connect process
482 (plist-get server-config :host)
483 (plist-get server-config :port)
484 (plist-get server-config :path)))
485 (let ((connection (apply #'make-instance
486 `(,(pcase connection-type
487 ('sse
488 'mcp-sse-process-connection)
489 ('stdio
490 'mcp-stdio-process-connection))
491 :connection-type ,connection-type
492 :name ,name
493 :process ,process
494 :request-dispatcher ,(lambda (_ method params)
495 (funcall #'mcp-request-dispatcher name method params))
496 :notification-dispatcher ,(lambda (connection method params)
497 (funcall #'mcp-notification-dispatcher connection name method params))
498 :on-shutdown ,(lambda (_)
499 (funcall #'mcp-on-shutdown name))
500 ,@(when (equal connection-type 'sse)
501 (list :host (plist-get server-config :host)
502 :port (plist-get server-config :port)
503 :tls (plist-get server-config :tls))))))
504 (initial-use-time 0)
505 (initial-timer nil))
506 ;; Initialize connection
507 (puthash name connection mcp-server-connections)
508 (when (equal connection-type 'sse)
509 (setf (mcp--status connection)
510 'waitendpoint))
511 ;; Send the Initialize message
512 (setf initial-timer
513 (run-with-idle-timer
514 1
515 t
516 #'(lambda ()
517 (cl-incf initial-use-time)
518 (if (jsonrpc-running-p connection)
519 (when (or (equal connection-type 'stdio)
520 (and (equal connection-type 'sse)
521 (mcp--endpoint connection)))
522 (cancel-timer initial-timer)
523 (mcp-async-initialize-message
524 connection
525 #'(lambda (protocolVersion serverInfo capabilities)
526 (if (string= protocolVersion *MCP-VERSION*)
527 (progn
528 (message "[mcp] Connected! Server `MCP (%s)' now managing." (jsonrpc-name connection))
529 (setf (mcp--capabilities connection) capabilities
530 (mcp--server-info connection) serverInfo)
531 ;; Notify server initialized
532 (mcp-notify connection
533 :notifications/initialized)
534 ;; handle logging
535 (when (plist-member capabilities :logging)
536 (mcp-async-set-log-level connection mcp-log-level))
537 (when initial-callback
538 (funcall initial-callback connection))
539 (run-with-idle-timer mcp-server-wait-initial-time
540 nil
541 #'(lambda ()
542 ;; Get prompts
543 (when (plist-member capabilities :prompts)
544 (mcp-async-list-prompts connection prompts-callback))
545 ;; Get tools
546 (when (plist-member capabilities :tools)
547 (mcp-async-list-tools connection tools-callback))
548 ;; Get resources
549 (when (plist-member capabilities :resources)
550 (mcp-async-list-resources connection resources-callback)))
551 )
552 (setf (mcp--status connection)
553 'connected))
554 (progn
555 (message "[mcp] Error %s server protocolVersion(%s) not support, client Version: %s."
556 (jsonrpc-name connection)
557 protocolVersion
558 *MCP-VERSION*)
559 (mcp-stop-server (jsonrpc-name connection)))))
560 #'(lambda (code message)
561 (when error-callback
562 (funcall error-callback code message))
563 (setf (mcp--status connection)
564 'error)
565 (message "Sadly, mpc server reports %s: %s"
566 code message)))
567 (when (> initial-use-time mcp-server-start-time)
568 (mcp-stop-server name)
569 (cancel-timer initial-timer)
570 (message "Sadly: mcp server start error timeout")))
571 (cancel-timer initial-timer)
572 (when error-callback
573 (funcall error-callback -1 "mcp server process start error")
574 (setf (mcp--status connection)
575 'error)
576 (message "Sadly, %s mcp server process start error" name))))))))))
577
578;;;###autoload
579(defun mcp-stop-server (name)
580 "Stop the MCP server with the given NAME.
581If the server is running, it will be shutdown and its connection will be removed
582from `mcp-server-connections'. If no server with the given NAME is found,
583a message will be displayed indicating that the server is not running."
584 (if-let* ((connection (gethash name mcp-server-connections)))
585 (progn
586 (jsonrpc-shutdown connection)
587 (setf (gethash name mcp-server-connections) nil))
588 (message "mcp %s server not started" name)))
589
590(defun mcp--parse-tool-args (properties required)
591 "Parse tool arguments from PROPERTIES and REQUIRED lists.
592
593PROPERTIES is a plist of tool argument properties.
594REQUIRED is a list of required argument names.
595
596The function processes each argument in PROPERTIES, marking optional arguments
597if they are not in REQUIRED. Each argument is parsed into a structured plist
598with :name, :type, and :optional fields.
599
600Returns a list of parsed argument plists."
601 (let ((need-length (- (/ (length properties) 2)
602 (length required))))
603 (cl-mapcar #'(lambda (arg-value required-name)
604 (pcase-let* ((`(,key ,value) arg-value))
605 `( :name ,(substring (symbol-name key) 1)
606 ,@value
607 ,@(unless required-name
608 `(:optional t)))))
609 (seq-partition properties 2)
610 (append required
611 (when (> need-length 0)
612 (make-list need-length nil))))))
613
614
615(defun mcp--parse-tool-call-result (res)
616 "Parse the result of a tool call from RES.
617
618RES is a plist representing the tool call result.
619
620The function extracts text content from the result, concatenating it into
621a single string if multiple text entries are present.
622
623Returns the concatenated text or nil if no text content is found."
624 (string-join
625 (cl-remove-if #'null
626 (mapcar #'(lambda (content)
627 (when (string= "text" (plist-get content :type))
628 (plist-get content :text)))
629 (plist-get res :content)))
630 "\n"))
631
632(defun mcp--generate-tool-call-args (args properties)
633 "Generate tool call arguments from ARGS and PROPERTIES.
634
635ARGS is a list of argument values provided by the caller.
636PROPERTIES is a plist of tool argument properties.
637
638The function matches ARGS to PROPERTIES, filling in default values for missing
639optional arguments. It ensures the generated arguments match the tool's schema.
640
641Returns a plist of argument names and values ready for tool invocation."
642 (let ((need-length (- (/ (length properties) 2)
643 (length args))))
644 (apply #'append
645 (cl-mapcar #'(lambda (arg value)
646 (when-let* ((value (if value
647 value
648 (plist-get (cl-second arg)
649 :default))))
650 (list (cl-first arg)
651 value)))
652 (seq-partition properties 2)
653 (append args
654 (when (> need-length 0)
655 (make-list need-length nil)))))))
656
657;;;###autoload
658(defun mcp-make-text-tool (name tool-name &optional asyncp)
659 "Create a `gptel' tool with the given NAME, TOOL-NAME, and ASYNCP.
660
661NAME is the name of the server connection.
662TOOL-NAME is the name of the tool to be created.
663
664Currently, only synchronous messages are supported.
665
666This function retrieves the tool definition from the server connection,
667constructs a basic tool with the appropriate properties, and returns it.
668The tool is configured to handle input arguments, call the server, and process
669the response to extract and return text content."
670 (when-let* ((connection (gethash name mcp-server-connections))
671 (tools (mcp--tools connection))
672 (tool (cl-find tool-name tools :test #'equal :key #'(lambda (tool) (plist-get tool :name)))))
673 (cl-destructuring-bind (&key description ((:inputSchema input-schema)) &allow-other-keys) tool
674 (cl-destructuring-bind (&key properties required &allow-other-keys) input-schema
675 (list
676 :function (if asyncp
677 #'(lambda (callback &rest args)
678 (when (< (length args) (length required))
679 (error "Error: args not match: %s -> %s" required args))
680 (if-let* ((connection (gethash name mcp-server-connections)))
681 (mcp-async-call-tool connection
682 tool-name
683 (mcp--generate-tool-call-args args properties)
684 #'(lambda (res)
685 (funcall callback
686 (mcp--parse-tool-call-result res)))
687 #'(lambda (code message)
688 (funcall callback
689 (format "call %s tool error with %s: %s"
690 tool-name
691 code
692 message))))
693 (error "Error: %s server not connect" name)))
694 #'(lambda (&rest args)
695 (when (< (length args) (length required))
696 (error "Error: args not match: %s -> %s" required args))
697 (if-let* ((connection (gethash name mcp-server-connections)))
698 (if-let* ((res (mcp-call-tool connection
699 tool-name
700 (mcp--generate-tool-call-args args properties))))
701 (mcp--parse-tool-call-result res)
702 (error "Error: call %s tool error" tool-name))
703 (error "Error: %s server not connect" name))))
704 :name tool-name
705 :async asyncp
706 :description description
707 :args
708 (mcp--parse-tool-args properties (or required '())))))))
709
710(defun mcp-async-set-log-level (connection log-level)
711 "Asynchronously set the log level for the MCP server.
712
713CONNECTION is the MCP connection object.
714LOG-LEVEL is the desired log level, which must be one of:
715- `debug': Detailed debugging information (function entry/exit points)
716- `info': General informational messages (operation progress updates)
717- `notice': Normal but significant events (configuration changes)
718- `warning': Warning conditions (deprecated feature usage)
719- `error': Error conditions (operation failures)
720- `critical': Critical conditions (system component failures)
721- `alert': Action must be taken immediately (data corruption detected)
722- `emergency': System is unusable (complete system failure)
723
724On success, displays a message confirming the log level change.
725On error, displays an error message with the server's response code and message."
726 (jsonrpc-async-request connection
727 :logging/setLevel
728 (list :level (format "%s" log-level))
729 :success-fn
730 #'(lambda (res)
731 (message "[mcp] setLevel success: %s" res))
732 :error-fn (jsonrpc-lambda (&key code message _data)
733 (message "Sadly, mpc server reports %s: %s"
734 code message))))
735
736(defun mcp-async-ping (connection)
737 "Send an asynchronous ping request to the MCP server via CONNECTION.
738
739The function uses `jsonrpc-async-request' to send a ping request.
740On success, it displays a message with the response.
741On error, it displays an error message with the code from the server."
742 (jsonrpc-async-request connection
743 :ping
744 nil
745 :success-fn
746 #'(lambda (res)
747 (message "[mcp] ping success: %s" res))
748 :error-fn (jsonrpc-lambda (&key code message _data)
749 (message "Sadly, mpc server reports %s: %s"
750 code message))))
751
752(defun mcp-async-initialize-message (connection callback &optional error-callback)
753 "Sending an `initialize' request to the CONNECTION.
754
755CONNECTION is the MCP connection object.
756CALLBACK is a function to call upon successful initialization.
757ERROR-CALLBACK is an optional function to call if an error occurs.
758
759This function sends an `initialize' request to the server
760with the client's capabilities and version information."
761 (jsonrpc-async-request connection
762 :initialize
763 (list :protocolVersion "2024-11-05"
764 :capabilities '(:roots (:listChanged t))
765 :clientInfo '(:name "mcp-emacs" :version "0.1.0"))
766 :success-fn
767 #'(lambda (res)
768 (cl-destructuring-bind (&key protocolVersion serverInfo capabilities &allow-other-keys) res
769 (funcall callback protocolVersion serverInfo capabilities)))
770 :error-fn
771 (jsonrpc-lambda (&key code message _data)
772 (if error-callback
773 (funcall error-callback code message)
774 (message "Sadly, mpc server reports %s: %s"
775 code message)))))
776
777(defun mcp-async-list-tools (connection &optional callback error-callback)
778 "Get a list of tools from the MCP server using the provided CONNECTION.
779
780CONNECTION is the MCP connection object.
781CALLBACK is a function to call with the result of the request.
782ERROR-CALLBACK is an optional function to call if the request fails.
783
784This function sends a request to the server to list available tools.
785The result is stored in the `mcp--tools' slot of the CONNECTION object."
786 (jsonrpc-async-request connection
787 :tools/list
788 '(:cursor "")
789 :success-fn
790 #'(lambda (res)
791 (cl-destructuring-bind (&key tools &allow-other-keys) res
792 (setf (mcp--tools connection)
793 tools)
794 (when callback
795 (funcall callback connection tools))))
796 :error-fn
797 (jsonrpc-lambda (&key code message _data)
798 (if error-callback
799 (funcall error-callback code message)
800 (message "Sadly, mpc server reports %s: %s"
801 code message)))))
802
803(defun mcp-call-tool (connection name arguments)
804 "Call a tool on the remote CONNECTION with NAME and ARGUMENTS.
805
806CONNECTION is the MCP connection object.
807NAME is the name of the tool to call.
808ARGGUMENTS is a list of arguments to pass to the tool."
809 (jsonrpc-request connection
810 :tools/call
811 (list :name name
812 :arguments (if arguments
813 arguments
814 #s(hash-table)))))
815
816(defun mcp-async-call-tool (connection name arguments callback error-callback)
817 "Async Call a tool on the remote CONNECTION with NAME and ARGUMENTS.
818
819CONNECTION is the MCP connection object.
820NAME is the name of the tool to call.
821ARGUMENTS is a list of arguments to pass to the tool.
822CALLBACK is a function to call on success.
823ERROR-CALLBACK is a function to call on error."
824 (jsonrpc-async-request connection
825 :tools/call
826 (list :name name
827 :arguments (if arguments
828 arguments
829 #s(hash-table)))
830 :success-fn
831 #'(lambda (res)
832 (funcall callback res))
833 :error-fn
834 (jsonrpc-lambda (&key code message _data)
835 (funcall error-callback code message))))
836
837(defun mcp-async-list-prompts (connection &optional callback error-callback)
838 "Get list of prompts from the MCP server using the provided CONNECTION.
839
840CONNECTION is the MCP connection object. CALLBACK is an optional function to
841call on success,which will receive the CONNECTION and the list of prompts.
842ERROR-CALLBACK is an optional function to call on error, which will receive the
843error code and message.
844
845The result is stored in the `mcp--prompts' slot of the CONNECTION object."
846 (jsonrpc-async-request connection
847 :prompts/list
848 '(:cursor "")
849 :success-fn
850 #'(lambda (res)
851 (cl-destructuring-bind (&key prompts &allow-other-keys) res
852 (setf (mcp--prompts connection)
853 prompts)
854 (when callback
855 (funcall callback connection prompts))))
856 :error-fn
857 (jsonrpc-lambda (&key code message _data)
858 (if error-callback
859 (funcall error-callback code message)
860 (message "Sadly, mpc server reports %s: %s"
861 code message)))))
862
863(defun mcp-get-prompt (connection name arguments)
864 "Call a prompt on the remote CONNECTION with NAME and ARGUMENTS.
865
866CONNECTION is the MCP connection object.
867NAME is the name of the prompt to call.
868ARGGUMENTS is a list of arguments to pass to the prompt"
869 (jsonrpc-request connection
870 :prompts/get
871 (list :name name
872 :arguments (if arguments
873 arguments
874 #s(hash-table)))))
875
876(defun mcp-async-get-prompt (connection name arguments callback error-callback)
877 "Async Call a prompt on the remote CONNECTION with NAME and ARGUMENTS.
878
879CONNECTION is the MCP connection object.
880NAME is the name of the prompt to call.
881ARGUMENTS is a list of arguments to pass to the prompt.
882CALLBACK is a function to call on successful response.
883ERROR-CALLBACK is a function to call on error."
884 (jsonrpc-async-request connection
885 :prompts/get
886 (list :name name
887 :arguments (if arguments
888 arguments
889 #s(hash-table)))
890 :success-fn
891 #'(lambda (res)
892 (funcall callback res))
893 :error-fn
894 (jsonrpc-lambda (&key code message _data)
895 (funcall error-callback code message))))
896
897(defun mcp-async-list-resources (connection &optional callback error-callback)
898 "Get list of resources from the MCP server using the provided CONNECTION.
899
900CONNECTION is the MCP connection object. CALLBACK is an optional function to
901call upon successful retrieval of resources. ERROR-CALLBACK is an optional
902function to call if an error occurs during the request.
903
904The result is stored in the `mcp--resources' slot of the CONNECTION object."
905 (jsonrpc-async-request connection
906 :resources/list
907 '(:cursor "")
908 :success-fn
909 #'(lambda (res)
910 (cl-destructuring-bind (&key resources &allow-other-keys) res
911 (setf (mcp--resources connection)
912 resources)
913 (when callback
914 (funcall callback connection resources))))
915 :error-fn
916 (jsonrpc-lambda (&key code message _data)
917 (if error-callback
918 (funcall error-callback code message)
919 (message "Sadly, mpc server reports %s: %s"
920 code message)))))
921(defun mcp-read-resource (connection uri)
922 "Call a resource on the remote CONNECTION with URI.
923
924CONNECTION is the MCP connection object.
925URI is the uri of the resource to call."
926 (jsonrpc-request connection
927 :resources/read
928 (list :uri uri)))
929
930(defun mcp-async-read-resource (connection uri &optional callback error-callback)
931 "Call a resource on the remote CONNECTION with URI.
932
933CONNECTION is the MCP connection object.
934URI is the URI of the resource to call.
935CALLBACK is a function to call with the result on success.
936ERROR-CALLBACK is a function to call with the error code and message on failure.
937
938This function asynchronously reads a resource from the remote connection
939using the specified URI. The result is passed to CALLBACK if the request
940succeeds, or ERROR-CALLBACK if it fails."
941 (jsonrpc-async-request connection
942 :resources/read
943 (list :uri uri)
944 :success-fn
945 #'(lambda (res)
946 (funcall callback res))
947 :error-fn
948 (jsonrpc-lambda (&key code message _data)
949 (funcall error-callback code message))))
950
951(defun mcp-async-list-resource-templates (connection &optional callback error-callback)
952 "Get list of resource templates from the MCP server using the CONNECTION.
953
954CONNECTION is the MCP connection object. CALLBACK is an optional function to
955call upon successful retrieval of resources. ERROR-CALLBACK is an optional
956function to call if an error occurs during the request."
957 (jsonrpc-async-request connection
958 :resources/templates/list
959 '(:cursor "")
960 :success-fn
961 #'(lambda (res)
962 (cl-destructuring-bind (&key resourceTemplates &allow-other-keys) res
963 (when callback
964 (funcall callback connection resourceTemplates))))
965 :error-fn
966 (jsonrpc-lambda (&key code message _data)
967 (if error-callback
968 (funcall error-callback code message)
969 (message "Sadly, mpc server reports %s: %s"
970 code message)))))
971
972(provide 'mcp)
973;;; mcp.el ends here