gptel-curl.el

;;; gptel-curl.el --- Curl support for GPTel         -*- lexical-binding: t; -*-

;; Copyright (C) 2023  Karthik Chikmagalur

;; Author: Karthik Chikmagalur;; <karthikchikmagalur@gmail.com>
;; Keywords: convenience

;; SPDX-License-Identifier: GPL-3.0-or-later

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; Curl support for GPTel.  Utility functions.

;;; Code:

(require 'gptel)

(eval-when-compile
  (require 'cl-lib)
  (require 'subr-x))
(require 'map)
(require 'json)

(defconst gptel-curl--common-args
  (if (memq system-type '(windows-nt ms-dos))
      '("--disable" "--location" "--silent" "-XPOST"
        "-y300" "-Y1" "-D-")
    '("--disable" "--location" "--silent" "--compressed"
      "-XPOST" "-y300" "-Y1" "-D-"))
  "Arguments always passed to Curl for gptel queries.")

(defvar gptel-curl--process-alist nil
  "Alist of active GPTel curl requests.")

(defun gptel-curl--get-args (prompts token)
  "Produce list of arguments for calling Curl.

PROMPTS is the data to send, TOKEN is a unique identifier."
  (let* ((url (let ((backend-url (gptel-backend-url gptel-backend)))
                    (if (functionp backend-url)
                        (funcall backend-url) backend-url)))
         (data (encode-coding-string
                (json-encode (gptel--request-data gptel-backend prompts))
                'utf-8))
         (headers
          (append '(("Content-Type" . "application/json"))
                  (when-let ((header (gptel-backend-header gptel-backend)))
                    (if (functionp header)
                        (funcall header) header)))))
    (append
     gptel-curl--common-args
     (list (format "-w(%s . %%{size_header})" token))
     (if (length< data gptel-curl-file-size-threshold)
         (list (format "-d%s" data))
       (letrec
           ((temp-filename (make-temp-file "gptel-curl-data" nil ".json" data))
            (cleanup-fn (lambda ()
                          (when (file-exists-p temp-filename)
                            (delete-file temp-filename)
                            (remove-hook 'gptel-post-response-hook cleanup-fn)))))
         (add-hook 'gptel-post-response-hook cleanup-fn)
         (list "--data-binary"
               (format "@%s" temp-filename))))
     (when (not (string-empty-p gptel-proxy))
       (list "--proxy" gptel-proxy
             "--proxy-negotiate"
             "--proxy-user" ":"))
     (cl-loop for (key . val) in headers
              collect (format "-H%s: %s" key val))
     (list url))))

;;TODO: The :transformer argument here is an alternate implementation of
;;`gptel-response-filter-functions'. The two need to be unified.
;;;###autoload
(defun gptel-curl-get-response (info &optional callback)
  "Retrieve response to prompt in INFO.

INFO is a plist with the following keys:
- :prompt (the prompt being sent)
- :buffer (the gptel buffer)
- :position (marker at which to insert the response).

Call CALLBACK with the response and INFO afterwards.  If omitted
the response is inserted into the current buffer after point."
  (let* ((token (md5 (format "%s%s%s%s"
                             (random) (emacs-pid) (user-full-name)
                             (recent-keys))))
         (args (gptel-curl--get-args (plist-get info :prompt) token))
         (stream (and gptel-stream (gptel-backend-stream gptel-backend)))
         (process (apply #'start-process "gptel-curl"
                         (generate-new-buffer "*gptel-curl*") "curl" args)))
    (when gptel--debug
      (message "%S" args))
    (with-current-buffer (process-buffer process)
      (set-process-query-on-exit-flag process nil)
      (setf (alist-get process gptel-curl--process-alist)
            (nconc (list :token token
                         ;; FIXME `aref' breaks `cl-struct' abstraction boundary
                         ;; FIXME `cl--generic-method' is an internal `cl-struct'
                         :parser (cl--generic-method-function
                                  (if stream
                                      (cl-find-method
                                       'gptel-curl--parse-stream nil
                                       (list
                                        (aref (buffer-local-value
                                               'gptel-backend (plist-get info :buffer))
                                              0) t))
                                    (cl-find-method
                                     'gptel--parse-response nil
                                     (list
                                      (aref (buffer-local-value
                                             'gptel-backend (plist-get info :buffer))
                                            0) t t))))
                         :callback (or callback
                                       (if stream
                                           #'gptel-curl--stream-insert-response
                                         #'gptel--insert-response))
                         :transformer (when (eq (buffer-local-value
                                                 'major-mode
                                                 (plist-get info :buffer))
                                                'org-mode)
                                        (gptel--stream-convert-markdown->org)))
                   info))
      (if stream
          (progn (set-process-sentinel process #'gptel-curl--stream-cleanup)
                 (set-process-filter process #'gptel-curl--stream-filter))
        (set-process-sentinel process #'gptel-curl--sentinel)))))

(defun gptel-abort (buf)
  "Stop any active gptel process associated with buffer BUF."
  (interactive (list (current-buffer)))
  (unless gptel-use-curl
    (user-error "Cannot stop a `url-retrieve' request!"))
  (if-let* ((proc-attrs
            (cl-find-if
             (lambda (proc-list)
               (eq (plist-get (cdr proc-list) :buffer) buf))
             gptel-curl--process-alist))
            (proc (car proc-attrs)))
      (progn
        (setf (alist-get proc gptel-curl--process-alist nil 'remove) nil)
        (set-process-sentinel proc #'ignore)
        (delete-process proc)
        (kill-buffer (process-buffer proc))
        (with-current-buffer buf
          (when gptel-mode (gptel--update-status  " Ready" 'success)))
        (message "Stopped gptel request in buffer %S" (buffer-name buf)))
    (message "No gptel request associated with buffer %S" (buffer-name buf))))

;; TODO: Separate user-messaging from this function
(defun gptel-curl--stream-cleanup (process _status)
  "Process sentinel for GPTel curl requests.

PROCESS and _STATUS are process parameters."
  (let ((proc-buf (process-buffer process)))
    (when gptel--debug
      (with-current-buffer proc-buf
        (clone-buffer "*gptel-error*" 'show)))
    (let* ((info (alist-get process gptel-curl--process-alist))
           (gptel-buffer (plist-get info :buffer))
           (backend-name
            (gptel-backend-name
             (buffer-local-value 'gptel-backend gptel-buffer)))
           (tracking-marker (plist-get info :tracking-marker))
           (start-marker (plist-get info :position))
           (http-status (plist-get info :http-status))
           (http-msg (plist-get info :status)))
      (if (equal http-status "200")
          (progn
            ;; Finish handling response
            (with-current-buffer (marker-buffer start-marker)
              (pulse-momentary-highlight-region (+ start-marker 2) tracking-marker)
              (when gptel-mode (save-excursion (goto-char tracking-marker)
                                               (insert "\n\n" (gptel-prompt-prefix-string)))))
            (with-current-buffer gptel-buffer
              (when gptel-mode (gptel--update-status  " Ready" 'success))))
        ;; Or Capture error message
        (with-current-buffer proc-buf
          (goto-char (point-max))
          (search-backward (plist-get info :token))
          (backward-char)
          (pcase-let* ((`(,_ . ,header-size) (read (current-buffer)))
                       (json-object-type 'plist)
                       (response (progn (goto-char header-size)
                                        (condition-case nil (json-read)
                                          (json-readtable-error 'json-read-error))))
                       (error-data (plist-get response :error)))
            (cond
             (error-data
              (if (stringp error-data)
                  (message "%s error: (%s) %s" backend-name http-msg error-data)
                (when-let ((error-msg (plist-get error-data :message)))
                    (message "%s error: (%s) %s" backend-name http-msg error-msg))
                (when-let ((error-type (plist-get error-data :type)))
                    (setq http-msg (concat "("  http-msg ") " (string-trim error-type))))))
             ((eq response 'json-read-error)
              (message "ChatGPT error (%s): Malformed JSON in response." http-msg))
             (t (message "ChatGPT error (%s): Could not parse HTTP response." http-msg)))))
        (with-current-buffer gptel-buffer
          (when gptel-mode
            (gptel--update-status
             (format " Response Error: %s" http-msg) 'error))))
      (with-current-buffer gptel-buffer
        (run-hooks 'gptel-post-response-hook)))
    (setf (alist-get process gptel-curl--process-alist nil 'remove) nil)
    (kill-buffer proc-buf)))

(defun gptel-curl--stream-insert-response (response info)
  "Insert streaming RESPONSE from ChatGPT into the gptel buffer.

INFO is a mutable plist containing information relevant to this buffer.
See `gptel--url-get-response' for details."
  (let ((start-marker (plist-get info :position))
        (tracking-marker (plist-get info :tracking-marker))
        (transformer (plist-get info :transformer)))
    (when response
        (with-current-buffer (marker-buffer start-marker)
          (save-excursion
            (unless tracking-marker
              (gptel--update-status " Typing..." 'success)
              (goto-char start-marker)
              (unless (or (bobp) (plist-get info :in-place))
                (insert "\n\n")
                (when gptel-mode
                  ;; Put prefix before AI response.
                  (insert (gptel-response-prefix-string))))
              (setq tracking-marker (set-marker (make-marker) (point)))
              (set-marker-insertion-type tracking-marker t)
              (plist-put info :tracking-marker tracking-marker))
            
            (when transformer
              (setq response (funcall transformer response)))
            
            (add-text-properties
             0 (length response) '(gptel response rear-nonsticky t)
             response)
            (goto-char tracking-marker)
            ;; (run-hooks 'gptel-pre-stream-hook)
            (insert response)
            (run-hooks 'gptel-post-stream-hook))))))

(defun gptel-curl--stream-filter (process output)
  (let* ((proc-info (alist-get process gptel-curl--process-alist)))
    (with-current-buffer (process-buffer process)
      ;; Insert output
      (save-excursion
        (goto-char (process-mark process))
        (insert output)
        (set-marker (process-mark process) (point)))
      
      ;; Find HTTP status
      (unless (plist-get proc-info :http-status)
        (save-excursion
          (goto-char (point-min))
          (when-let* (((not (= (line-end-position) (point-max))))
                      (http-msg (buffer-substring (line-beginning-position)
                                                  (line-end-position)))
                      (http-status
                       (save-match-data
                         (and (string-match "HTTP/[.0-9]+ +\\([0-9]+\\)" http-msg)
                              (match-string 1 http-msg)))))
            (plist-put proc-info :http-status http-status)
            (plist-put proc-info :status (string-trim http-msg))))
        ;; Handle read-only gptel buffer
        (when (with-current-buffer (plist-get proc-info :buffer)
                (or buffer-read-only
                    (get-char-property (plist-get proc-info :position) 'read-only)))
          (message "Buffer is read only, displaying reply in buffer \"*ChatGPT response*\"")
          (display-buffer
           (with-current-buffer (get-buffer-create "*ChatGPT response*")
             (goto-char (point-max))
             (move-marker (plist-get proc-info :position) (point) (current-buffer))
             (current-buffer))
           '((display-buffer-reuse-window
              display-buffer-pop-up-window)
             (reusable-frames . visible))))
        ;; Run pre-response hook
        (when (and (equal (plist-get proc-info :http-status) "200")
                   gptel-pre-response-hook)
          (with-current-buffer (marker-buffer (plist-get proc-info :position))
            (run-hooks 'gptel-pre-response-hook))))
      
      (when-let ((http-msg (plist-get proc-info :status))
                 (http-status (plist-get proc-info :http-status)))
        ;; Find data chunk(s) and run callback
        (when-let (((equal http-status "200"))
                   (response (funcall (plist-get proc-info :parser) nil proc-info))
                   ((not (equal response ""))))
          (funcall (or (plist-get proc-info :callback)
                       #'gptel-curl--stream-insert-response)
                   response proc-info))))))

(cl-defgeneric gptel-curl--parse-stream (backend proc-info)
  "Stream parser for gptel-curl.

Implementations of this function run as part of the process
filter for the active query, and return partial responses from
the LLM.

BACKEND is the LLM backend in use.

PROC-INFO is a plist with process information and other context.
See `gptel-curl--get-response' for its contents.")

(defun gptel-curl--sentinel (process _status)
  "Process sentinel for gptel curl requests.

PROCESS and _STATUS are process parameters."
  (let ((proc-buf (process-buffer process)))
    (when gptel--debug
      (with-current-buffer proc-buf
        (clone-buffer "*gptel-error*" 'show)))
    (when-let* (((eq (process-status process) 'exit))
                (proc-info (alist-get process gptel-curl--process-alist))
                (proc-callback (plist-get proc-info :callback)))
      (pcase-let ((`(,response ,http-msg ,error)
                   (with-current-buffer proc-buf
                     (gptel-curl--parse-response proc-info))))
        (plist-put proc-info :status http-msg)
        (when error (plist-put proc-info :error error))
        (funcall proc-callback response proc-info)))
    (setf (alist-get process gptel-curl--process-alist nil 'remove) nil)
    (kill-buffer proc-buf)))

(defun gptel-curl--parse-response (proc-info)
  "Parse the buffer BUF with curl's response.

PROC-INFO is a plist with contextual information."
  (let ((token (plist-get proc-info :token))
        (parser (plist-get proc-info :parser)))
    (goto-char (point-max))
    (search-backward token)
    (backward-char)
    (pcase-let* ((`(,_ . ,header-size) (read (current-buffer))))
      (goto-char (point-min))

      (if-let* ((http-msg (string-trim
                           (buffer-substring (line-beginning-position)
                                             (line-end-position))))
                (http-status
                 (save-match-data
                   (and (string-match "HTTP/[.0-9]+ +\\([0-9]+\\)" http-msg)
                        (match-string 1 http-msg))))
                (json-object-type 'plist)
                (response (progn (goto-char header-size)
                                 (condition-case nil
                                     (json-read)
                                   (json-readtable-error 'json-read-error)))))
          (cond
           ((equal http-status "200")
            (list (string-trim
                   (funcall parser nil response proc-info))
                  http-msg))
           ((plist-get response :error)
            (let* ((error-data (plist-get response :error))
                   (error-msg (plist-get error-data :message))
                   (error-type (plist-get error-data :type))
                   (backend-name
                    (gptel-backend-name
                     (buffer-local-value 'gptel-backend (plist-get proc-info :buffer)))))
              (if (stringp error-data)
                  (progn (message "%s error: (%s) %s" backend-name http-msg error-data)
                         (setq error-msg (string-trim error-data)))
                (when (stringp error-msg)
                  (message "%s error: (%s) %s" backend-name http-msg (string-trim error-msg)))
                (when error-type (setq http-msg (concat "("  http-msg ") " (string-trim error-type)))))
              (list nil (concat "(" http-msg ") " (or error-msg "")))))
           ((eq response 'json-read-error)
            (list nil (concat "(" http-msg ") Malformed JSON in response.")
                  "Malformed JSON in response"))
           (t (list nil (concat "(" http-msg ") Could not parse HTTP response.")
                    "Could not parse HTTP response.")))
        (list nil (concat "(" http-msg ") Could not parse HTTP response.")
              "Could not parse HTTP response.")))))

(provide 'gptel-curl)
;;; gptel-curl.el ends here