;;; doctor-boring-test.el --- Doctor Boring tests -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: WTFPL
;;; Code:
(require 'ert)
(require 'doctor-boring)
(defvar doctor-boring-test--capture nil)
(defmacro doctor-boring-test--with-buffer (&rest body)
"Run BODY in an isolated, initialized conversation buffer."
(declare (indent 0) (debug t))
`(let ((doctor-boring-endpoint "https://example.test/v1")
(doctor-boring-api-key "test-key")
(doctor-boring-model "test-model")
(doctor-boring-temperature 0.25)
(doctor-boring-system-prompt "System text")
(doctor-boring-greeting "Test greeting")
(doctor-boring-request-timeout 60)
(buffer (generate-new-buffer " *doctor-boring-test*")))
(unwind-protect
(with-current-buffer buffer
(cl-letf (((symbol-function
'doctor-boring--select-presentation-mode)
#'text-mode))
(doctor-boring--initialize-buffer))
,@body)
(when (buffer-live-p buffer)
(kill-buffer buffer)))))
(defun doctor-boring-test--fake-retrieve
(url callback callback-arguments silent no-cookies)
"Capture retrieval arguments for a deterministic test response."
(let ((retrieval (generate-new-buffer " *doctor-boring-response*")))
(setq doctor-boring-test--capture
(list :url url
:callback callback
:arguments callback-arguments
:silent silent
:no-cookies no-cookies
:method url-request-method
:headers (copy-tree url-request-extra-headers)
:data url-request-data
:conversation-read-only buffer-read-only
:buffer retrieval))
retrieval))
(defun doctor-boring-test--deliver (status-code body &optional status)
"Deliver STATUS-CODE and BODY to the captured callback with STATUS."
(let ((retrieval (plist-get doctor-boring-test--capture :buffer))
(callback (plist-get doctor-boring-test--capture :callback))
(arguments (plist-get doctor-boring-test--capture :arguments)))
(with-current-buffer retrieval
(let ((inhibit-read-only t))
(erase-buffer)
(set-buffer-multibyte nil)
(insert "HTTP/1.1 response\r\n\r\n")
(setq-local url-http-end-of-headers (point))
(insert (encode-coding-string body 'utf-8))
(setq-local url-http-response-status status-code)
(apply callback (or status nil) arguments)))))
(defun doctor-boring-test--submit (text)
"Insert and submit TEXT in the current conversation buffer."
(goto-char (point-max))
(insert text)
(doctor-boring--submit-immediately))
(defun doctor-boring-test--content-list ()
"Return current history as role and content pairs."
(mapcar (lambda (message)
(list (alist-get 'role message)
(alist-get 'content message)))
(doctor-boring--build-messages)))
(ert-deftest doctor-boring-test-default-system-prompt-contract ()
(let ((prompt
(eval (car (get 'doctor-boring-system-prompt 'standard-value))
t)))
(should (string-match-p "classic Emacs Doctor and ELIZA" prompt))
(should (string-match-p "Keep the quirk subtle" prompt))
(should (string-match-p
"Every response must end with a natural question" prompt))))
(ert-deftest doctor-boring-test-endpoint-and-headers ()
(let ((doctor-boring-endpoint "https://example.test/v1")
(doctor-boring-api-key " secret "))
(should (equal (doctor-boring--chat-completions-url)
"https://example.test/v1/chat/completions"))
(setq doctor-boring-endpoint "https://example.test/v1///")
(should (equal (doctor-boring--chat-completions-url)
"https://example.test/v1/chat/completions"))
(should (equal (cdr (assoc "Authorization"
(doctor-boring--request-headers)))
"Bearer secret"))
(should (equal (doctor-boring--redact-api-key
"provider repeated secret")
"provider repeated [REDACTED]"))
(setq doctor-boring-api-key " ")
(should-not (assoc "Authorization"
(doctor-boring--request-headers)))
(setq doctor-boring-endpoint " /// ")
(should-error (doctor-boring--chat-completions-url))))
(ert-deftest doctor-boring-test-request-serialization ()
(let* ((doctor-boring-model "")
(doctor-boring-temperature 0.75)
(messages '(((role . "system") (content . "systém"))
((role . "user") (content . "hello"))))
(json (decode-coding-string
(doctor-boring--serialize-request messages) 'utf-8))
(parsed (json-parse-string json
:object-type 'plist
:array-type 'list)))
(should (equal (plist-get parsed :model) ""))
(should (= (plist-get parsed :temperature) 0.75))
(should (equal (mapcar (lambda (item) (plist-get item :content))
(plist-get parsed :messages))
'("systém" "hello")))
(should (string-match-p "\\[" json))))
(ert-deftest doctor-boring-test-response-parsing ()
(should (equal
(doctor-boring--parse-response
"{\"choices\":[{\"message\":{\"content\":\" héllo \"}}]}")
"héllo"))
(dolist (body '("{}"
"{\"choices\":[{}]}"
"{\"choices\":[{\"message\":{\"content\":null}}]}"
"{\"choices\":[{\"message\":{\"content\":3}}]}"
"{\"choices\":[{\"message\":{\"content\":\" \"}}]}"
"not-json"))
(should-error (doctor-boring--parse-response body))))
(ert-deftest doctor-boring-test-greeting-is-presentation-only ()
(doctor-boring-test--with-buffer
(should (equal (buffer-string) "Test greeting\n\n"))
(should-not doctor-boring--messages)
(goto-char (point-min))
(delete-region (point) (+ (point) 4))
(insert "Edited")
(should (equal (doctor-boring-test--content-list)
'(("system" "System text"))))
(let ((doctor-boring-system-prompt "New system"))
(should (equal (caar (doctor-boring-test--content-list))
"system"))
(should (equal (cadar (doctor-boring-test--content-list))
"New system")))))
(ert-deftest doctor-boring-test-command-reuses-and-resets-buffer ()
(let ((doctor-boring-greeting "First greeting")
(original (get-buffer "*doctor-boring*")))
(when original
(kill-buffer original))
(unwind-protect
(save-window-excursion
(cl-letf (((symbol-function
'doctor-boring--select-presentation-mode)
#'text-mode))
(doctor-boring)
(insert "draft")
(let ((first (current-buffer)))
(doctor-boring)
(should (eq (current-buffer) first))
(should (equal (buffer-string)
"First greeting\n\ndraft"))
(kill-buffer first)
(setq doctor-boring-greeting "Second greeting")
(doctor-boring)
(should (equal (buffer-string)
"Second greeting\n\n")))))
(when (get-buffer "*doctor-boring*")
(kill-buffer "*doctor-boring*")))))
(ert-deftest doctor-boring-test-mode-selection ()
(with-temp-buffer
(cl-letf (((symbol-function 'require)
(lambda (feature &optional _filename _noerror)
(unless (eq feature 'markdown-mode)
(error "Unexpected feature"))
nil)))
(doctor-boring--select-presentation-mode)
(should (derived-mode-p 'text-mode))))
(with-temp-buffer
(cl-letf (((symbol-function 'require)
(lambda (&rest _arguments)
(error "Broken optional package"))))
(doctor-boring--select-presentation-mode)
(should (derived-mode-p 'text-mode))))
(with-temp-buffer
(cl-letf (((symbol-function 'require)
(lambda (&rest _arguments) t))
((symbol-function 'markdown-mode)
(lambda () (fundamental-mode)
(setq major-mode 'markdown-mode))))
(doctor-boring--select-presentation-mode)
(should (eq major-mode 'markdown-mode)))))
(ert-deftest doctor-boring-test-minor-mode-and-auto-fill ()
(doctor-boring-test--with-buffer
(should doctor-boring-mode)
(should auto-fill-function)
(should (eq (key-binding (kbd "RET"))
#'doctor-boring--return))
(should (eq (key-binding (kbd "C-j"))
#'doctor-boring--submit-immediately))))
(ert-deftest doctor-boring-test-return-and-immediate-submission ()
(doctor-boring-test--with-buffer
(let* ((started 0)
(doctor-boring--retrieve-function
(lambda (&rest arguments)
(cl-incf started)
(apply #'doctor-boring-test--fake-retrieve arguments))))
(goto-char (point-min))
(doctor-boring--return)
(should (eq (char-before) ?\n))
(doctor-boring--submit-immediately)
(should (eq (char-before) ?\n))
(goto-char (point-max))
(insert "hello")
(doctor-boring--return)
(should (string-suffix-p "hello\n" (buffer-string)))
(should (= started 0))
(doctor-boring--return)
(should (= started 1))
(should buffer-read-only))))
(ert-deftest doctor-boring-test-whitespace-only-input-is-cleared ()
(doctor-boring-test--with-buffer
(let* ((called nil)
(doctor-boring--retrieve-function
(lambda (&rest _arguments) (setq called t))))
(insert " \n \t")
(doctor-boring--submit-immediately)
(should-not called)
(should (equal (buffer-string) "Test greeting\n\n"))
(should-not buffer-read-only))))
(ert-deftest doctor-boring-test-request-capture-and-success ()
(doctor-boring-test--with-buffer
(let ((doctor-boring-test--capture nil)
(doctor-boring--retrieve-function
#'doctor-boring-test--fake-retrieve))
(doctor-boring-test--submit " héllo ")
(should buffer-read-only)
(should (equal (plist-get doctor-boring-test--capture :url)
"https://example.test/v1/chat/completions"))
(should (equal (plist-get doctor-boring-test--capture :method)
"POST"))
(should (plist-get doctor-boring-test--capture :silent))
(should (plist-get doctor-boring-test--capture :no-cookies))
(should (plist-get doctor-boring-test--capture
:conversation-read-only))
(let* ((data (decode-coding-string
(plist-get doctor-boring-test--capture :data) 'utf-8))
(parsed (json-parse-string data
:object-type 'plist
:array-type 'list)))
(should (equal
(mapcar (lambda (item) (plist-get item :content))
(plist-get parsed :messages))
'("System text" "héllo"))))
(doctor-boring-test--deliver
200 "{\"choices\":[{\"message\":{\"content\":\" reply \"}}]}")
(should-not buffer-read-only)
(should-not doctor-boring--active-request)
(should (equal (buffer-string)
"Test greeting\n\nhéllo\n\nreply\n\n"))
(should (equal (doctor-boring-test--content-list)
'(("system" "System text")
("user" "héllo")
("assistant" "reply")))))))
(ert-deftest doctor-boring-test-success-does-not-select-buffer ()
(doctor-boring-test--with-buffer
(let ((conversation (current-buffer))
(other (generate-new-buffer " *doctor-boring-other*"))
(doctor-boring-test--capture nil)
(doctor-boring--retrieve-function
#'doctor-boring-test--fake-retrieve))
(unwind-protect
(progn
(doctor-boring-test--submit "hello")
(switch-to-buffer other)
(doctor-boring-test--deliver
200
"{\"choices\":[{\"message\":{\"content\":\"reply\"}}]}")
(should (eq (current-buffer) other))
(with-current-buffer conversation
(should (string-suffix-p "reply\n\n" (buffer-string)))))
(when (buffer-live-p other)
(kill-buffer other))))))
(ert-deftest doctor-boring-test-failures-roll-back-and-retry ()
(doctor-boring-test--with-buffer
(let ((doctor-boring-test--capture nil)
diagnostic
(doctor-boring--retrieve-function
#'doctor-boring-test--fake-retrieve))
(doctor-boring-test--submit "hello")
(cl-letf (((symbol-function 'message)
(lambda (format-string &rest arguments)
(setq diagnostic
(apply #'format format-string arguments)))))
(doctor-boring-test--deliver 503 "provider detail"))
(should-not buffer-read-only)
(should (string-match-p "HTTP 503; body: provider detail"
diagnostic))
(should-not (string-match-p "test-key" diagnostic))
(should (string-suffix-p
"[Doctor Boring error: HTTP request failed.]\n\nhello"
(buffer-string)))
(should-not doctor-boring--messages)
(should (equal (doctor-boring-test--content-list)
'(("system" "System text"))))
(doctor-boring--submit-immediately)
(should buffer-read-only)
(should (= (doctor-boring--request-id
doctor-boring--active-request)
2)))))
(ert-deftest doctor-boring-test-transport-and-malformed-failures ()
(dolist (delivery '((nil "" (:error (error connection-failed)))
(200 "{\"choices\":[]}" nil)))
(doctor-boring-test--with-buffer
(let ((doctor-boring-test--capture nil)
(doctor-boring--retrieve-function
#'doctor-boring-test--fake-retrieve))
(doctor-boring-test--submit "again")
(apply #'doctor-boring-test--deliver delivery)
(should-not buffer-read-only)
(should (string-suffix-p "\n\nagain" (buffer-string)))))))
(ert-deftest doctor-boring-test-empty-endpoint-rolls-back-locally ()
(doctor-boring-test--with-buffer
(let* ((doctor-boring-endpoint " ")
(called nil)
(doctor-boring--retrieve-function
(lambda (&rest _arguments) (setq called t))))
(doctor-boring-test--submit "local")
(should-not called)
(should-not buffer-read-only)
(should (string-suffix-p "\n\nlocal" (buffer-string)))
(should (= doctor-boring--request-sequence 1)))))
(ert-deftest doctor-boring-test-editing-completed-messages ()
(doctor-boring-test--with-buffer
(let ((doctor-boring-test--capture nil)
(doctor-boring--retrieve-function
#'doctor-boring-test--fake-retrieve))
(doctor-boring-test--submit "first")
(doctor-boring-test--deliver
200 "{\"choices\":[{\"message\":{\"content\":\"answer\"}}]}")
(let* ((user (nth 0 doctor-boring--messages))
(assistant (nth 1 doctor-boring--messages)))
(goto-char (doctor-boring--message-start user))
(delete-region (point) (doctor-boring--message-end user))
(insert " edited inside ")
(goto-char (doctor-boring--message-start assistant))
(delete-region (point) (doctor-boring--message-end assistant))
(insert "changed")
(should (equal (doctor-boring-test--content-list)
'(("system" "System text")
("user" "edited inside")
("assistant" "changed"))))))))
(ert-deftest doctor-boring-test-cross-boundary-deletion-normalizes ()
(doctor-boring-test--with-buffer
(let ((doctor-boring-test--capture nil)
(doctor-boring--retrieve-function
#'doctor-boring-test--fake-retrieve))
(doctor-boring-test--submit "first")
(doctor-boring-test--deliver
200 "{\"choices\":[{\"message\":{\"content\":\"answer\"}}]}")
(let ((user (nth 0 doctor-boring--messages))
(assistant (nth 1 doctor-boring--messages)))
(delete-region
(1- (marker-position (doctor-boring--message-end user)))
(1+ (marker-position
(doctor-boring--message-start assistant))))
(cl-loop for (message next) on doctor-boring--messages
while next
do (should
(<= (marker-position
(doctor-boring--message-end message))
(marker-position
(doctor-boring--message-start next)))))
(should
(<= (marker-position
(doctor-boring--message-end
(car (last doctor-boring--messages))))
(marker-position doctor-boring--input-start)))))))
(ert-deftest doctor-boring-test-empty-record-is-skipped ()
(doctor-boring-test--with-buffer
(let ((empty (doctor-boring--insert-message 'user "")))
(setq doctor-boring--messages
(append doctor-boring--messages (list empty)))
(set-marker doctor-boring--input-start (point-max))
(should (= (length (doctor-boring--build-messages)) 1)))))
(ert-deftest doctor-boring-test-timeout-and-stale-callback ()
(doctor-boring-test--with-buffer
(let ((doctor-boring-test--capture nil)
(doctor-boring--retrieve-function
#'doctor-boring-test--fake-retrieve))
(doctor-boring-test--submit "slow")
(let ((request doctor-boring--active-request)
(callback (plist-get doctor-boring-test--capture :callback))
(arguments (plist-get doctor-boring-test--capture :arguments)))
(doctor-boring--timeout request)
(should (doctor-boring--request-completed request))
(should-not (doctor-boring--request-timer request))
(should-not buffer-read-only)
(should (string-suffix-p "\n\nslow" (buffer-string)))
(let ((stale (generate-new-buffer " *doctor-boring-stale*")))
(with-current-buffer stale
(set-buffer-multibyte nil)
(insert "HTTP\r\n\r\n{}")
(setq-local url-http-end-of-headers 9)
(setq-local url-http-response-status 200)
(apply callback nil arguments))
(should-not (buffer-live-p stale)))
(should (string-suffix-p "\n\nslow" (buffer-string)))))))
(ert-deftest doctor-boring-test-synchronous-callback-start-ordering ()
(doctor-boring-test--with-buffer
(let ((doctor-boring--retrieve-function
(lambda (_url callback arguments _silent _no-cookies)
(let ((response
(generate-new-buffer " *doctor-boring-fast*")))
(with-current-buffer response
(set-buffer-multibyte nil)
(insert "HTTP\r\n\r\n")
(setq-local url-http-end-of-headers (point))
(insert
"{\"choices\":[{\"message\":{\"content\":\"fast\"}}]}")
(setq-local url-http-response-status 200)
(apply callback nil arguments))
response))))
(doctor-boring-test--submit "now")
(should-not buffer-read-only)
(should-not doctor-boring--active-request)
(should (string-suffix-p "now\n\nfast\n\n" (buffer-string))))))
(ert-deftest doctor-boring-test-stale-callback-after-success ()
(doctor-boring-test--with-buffer
(let ((doctor-boring-test--capture nil)
(doctor-boring--retrieve-function
#'doctor-boring-test--fake-retrieve))
(doctor-boring-test--submit "once")
(let ((callback (plist-get doctor-boring-test--capture :callback))
(arguments (plist-get doctor-boring-test--capture :arguments)))
(doctor-boring-test--deliver
200
"{\"choices\":[{\"message\":{\"content\":\"only\"}}]}")
(let ((completed-text (buffer-string))
(stale (generate-new-buffer " *doctor-boring-stale*")))
(with-current-buffer stale
(apply callback '(:error (error late)) arguments))
(should-not (buffer-live-p stale))
(should (equal (buffer-string) completed-text)))))))
(ert-deftest doctor-boring-test-immediate-start-error-rolls-back ()
(doctor-boring-test--with-buffer
(let ((doctor-boring--retrieve-function
(lambda (&rest _arguments)
(error "setup failed"))))
(doctor-boring-test--submit "retry me")
(should-not buffer-read-only)
(should-not doctor-boring--active-request)
(should (string-suffix-p "\n\nretry me" (buffer-string))))))
(ert-deftest doctor-boring-test-success-insertion-error-rolls-back ()
(doctor-boring-test--with-buffer
(let ((doctor-boring-test--capture nil)
(doctor-boring--retrieve-function
#'doctor-boring-test--fake-retrieve)
(original-insert
(symbol-function 'doctor-boring--insert-message)))
(doctor-boring-test--submit "do not lose me")
(cl-letf (((symbol-function 'doctor-boring--insert-message)
(lambda (role content)
(if (eq role 'assistant)
(error "insertion failed")
(funcall original-insert role content)))))
(doctor-boring-test--deliver
200
"{\"choices\":[{\"message\":{\"content\":\"reply\"}}]}"))
(should-not buffer-read-only)
(should-not doctor-boring--active-request)
(should-not doctor-boring--messages)
(should (string-suffix-p "\n\ndo not lose me" (buffer-string))))))
(ert-deftest doctor-boring-test-killing-conversation-cleans-request ()
(let ((doctor-boring-endpoint "https://example.test/v1")
(doctor-boring-request-timeout 60)
(doctor-boring-test--capture nil)
(doctor-boring--retrieve-function
#'doctor-boring-test--fake-retrieve)
request retrieval)
(let ((buffer (generate-new-buffer " *doctor-boring-kill-test*")))
(with-current-buffer buffer
(cl-letf (((symbol-function
'doctor-boring--select-presentation-mode)
#'text-mode))
(doctor-boring--initialize-buffer))
(doctor-boring-test--submit "bye")
(setq request doctor-boring--active-request)
(setq retrieval
(doctor-boring--request-retrieval-buffer request)))
(kill-buffer buffer))
(should (doctor-boring--request-completed request))
(should-not (doctor-boring--request-timer request))
(should-not (buffer-live-p retrieval))))
(provide 'doctor-boring-test)
;;; doctor-boring-test.el ends here