;;; nrepl-bencode.el --- Bencode encoding/decoding for nREPL -*- lexical-binding: t -*-

;; Copyright © 2012-2026 Tim King, Phil Hagelberg, Bozhidar Batsov
;; Copyright © 2013-2026 Bozhidar Batsov, Artur Malabarba and CIDER contributors
;;
;; Author: Tim King <kingtim@gmail.com>
;;         Phil Hagelberg <technomancy@gmail.com>
;;         Bozhidar Batsov <bozhidar@batsov.dev>
;;         Artur Malabarba <bruce.connor.am@gmail.com>
;;         Hugo Duncan <hugo@hugoduncan.org>
;;         Steve Purcell <steve@sanityinc.com>

;; 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 <http://www.gnu.org/licenses/>.

;; This file is not part of GNU Emacs.

;;; Commentary:

;; Bencode encoding and decoding as used by the nREPL protocol.
;; See http://en.wikipedia.org/wiki/Bencode for the encoding specification.

;;; Code:

(require 'cl-lib)
(require 'nrepl-dict)
(require 'queue)

(declare-function nrepl-log-error "nrepl-client")
(defvar nrepl-error-buffer-name)


;;; Response Queue

(cl-defstruct (nrepl-response-queue
               (:include queue)
               (:constructor nil)
               (:constructor nrepl-response-queue (&optional stub)))
  stub)

(put 'nrepl-response-queue 'function-documentation
     "Create queue object used by nREPL to store decoded server responses.
The STUB slot stores a stack of nested, incompletely parsed objects.")


;;; Decoding

(defun nrepl--bdecode-list (&optional stack)
  "Decode a bencode list or dict starting at point.
STACK is as in `nrepl--bdecode-1'."
  ;; skip leading l or d
  (forward-char 1)
  (let* ((istack (nrepl--bdecode-1 stack))
         (pos0 (point))
         (info (car istack)))
    (while (null info)
      (setq istack (nrepl--bdecode-1 (cdr istack))
            pos0 (point)
            info (car istack)))
    (cond ((eq info :e)
           (cons nil (cdr istack)))
          ((eq info :stub)
           (goto-char pos0)
           istack)
          (t istack))))

(defun nrepl--bdecode-1 (&optional stack)
  "Decode one elementary bencode object starting at point.
Bencoded object is either list, dict, integer or string.  See
http://en.wikipedia.org/wiki/Bencode#Encoding_algorithm for the encoding
rules.

STACK is a list of so far decoded components of the current message.  Car
of STACK is the innermost incompletely decoded object.  The algorithm pops
this list when inner object was completely decoded or grows it by one when
new list or dict was encountered.

The returned value is of the form (INFO . STACK) where INFO is
:stub, nil, :e, :end or :eob and STACK is either an incomplete parsing state as
above (INFO is :stub, nil, :e or :eob) or a list of one component representing
the completely decoded message (INFO is :end).  INFO is nil when an
elementary non-root object was successfully decoded.  INFO is :e when a
non-root list or dict was decoded.  INFO is :end when this object is a root
list or dict."
  (cond
   ;; list
   ((eq (char-after) ?l)
    (nrepl--bdecode-list (cons () stack)))
   ;; dict
   ((eq (char-after) ?d)
    (nrepl--bdecode-list (cons '(dict) stack)))
   ;; end of a list or a dict
   ((eq (char-after) ?e)
    (forward-char 1)
    (cons (if (cdr stack) :e :end)
          (nrepl--push (nrepl--nreverse (car stack))
                       (cdr stack))))
   ;; string
   ((looking-at "\\([0-9]+\\):")
    (let ((pos0 (point))
          (beg (goto-char (match-end 0)))
          (end (byte-to-position (+ (position-bytes (point))
                                    (string-to-number (match-string 1))))))
      (if (null end)
          (progn (goto-char pos0)
                 (cons :stub stack))
        (goto-char end)
        ;; normalise any platform-specific newlines
        (let* ((original (buffer-substring-no-properties beg end))
               (result (if (string-search "\r" original)
                           (replace-regexp-in-string "\r\n\\|\n\r\\|\r" "\n" original)
                         original)))
          (cons nil (nrepl--push result stack))))))
   ;; integer
   ((looking-at "i\\(-?[0-9]+\\)e")
    (goto-char (match-end 0))
    (cons nil (nrepl--push (string-to-number (match-string 1))
                           stack)))
   ;; should happen in tests only as eobp is checked in nrepl-bdecode.
   ((eobp)
    (cons :eob stack))
   ;; truncation in the middle of an integer or in 123: string prefix
   ((looking-at-p "[0-9i]")
    (cons :stub stack))
   ;; else, throw a quiet error
   (t (nrepl--bdecode-error))))

(defun nrepl--bdecode-error ()
  "Handle an unrecoverable bencode parse failure.
Log the offending position and the remaining buffer to the nREPL error
buffer, surface a notification to the user, and return an `:end' cons
that drains the rest of the buffer so the decoder loop terminates."
  (message "Invalid bencode message detected. See the %s buffer for details."
           nrepl-error-buffer-name)
  (nrepl-log-error
   (format "Decoder error at position %d (`%s'):"
           (point) (buffer-substring (point) (min (+ (point) 10) (point-max)))))
  (nrepl-log-error (buffer-string))
  (ding)
  ;; Drain the buffer so `nrepl-bdecode' exits its loop with clean queue state.
  (goto-char (point-max))
  (cons :end nil))

(defun nrepl--bdecode-message (&optional stack)
  "Decode one full message starting at point.
STACK is as in `nrepl--bdecode-1'.  Return a cons (INFO . STACK)."
  (let* ((istack (nrepl--bdecode-1 stack))
         (info (car istack))
         (stack (cdr istack)))
    (while (or (null info)
               (eq info :e))
      (setq istack (nrepl--bdecode-1 stack)
            info (car istack)
            stack (cdr istack)))
    istack))

(defun nrepl--ensure-fundamental-mode ()
  "Enable `fundamental-mode' if it is not enabled already."
  (unless (eq 'fundamental-mode major-mode)
    (fundamental-mode)))

(defun nrepl-bdecode (string-q &optional response-q)
  "Decode STRING-Q and place the results into RESPONSE-Q.
STRING-Q is either a queue of strings or a string.  RESPONSE-Q is a queue of
server requests (nREPL dicts).  STRING-Q and RESPONSE-Q are modified by side
effects.

Return a cons (STRING-Q . RESPONSE-Q) where STRING-Q is the original queue
containing the remainder of the input strings which could not be
decoded.  RESPONSE-Q is the original queue with successfully decoded messages
enqueued and with slot STUB containing a nested stack of an incompletely
decoded message or nil if the strings were completely decoded."
  ;; A persistent hidden buffer is reused across calls instead of
  ;; `with-temp-buffer' to avoid per-message buffer allocation on the
  ;; nREPL hot path.
  (with-current-buffer (get-buffer-create " *nrepl-decoding*")
    ;; Don't needlessly call `fundamental-mode', to prevent needlessly firing
    ;; hooks. This fixes an issue with evil-mode where the cursor loses its
    ;; correct color.
    (nrepl--ensure-fundamental-mode)
    (erase-buffer)
    (if (queue-p string-q)
        (while (queue-head string-q)
          (insert (queue-dequeue string-q)))
      (insert string-q)
      (setq string-q (queue-create)))
    (goto-char 1)
    (unless response-q
      (setq response-q (nrepl-response-queue)))
    (let ((istack (nrepl--bdecode-message
                   (nrepl-response-queue-stub response-q))))
      (while (and (eq (car istack) :end)
                  (not (eobp)))
        (queue-enqueue response-q (cadr istack))
        (setq istack (nrepl--bdecode-message)))
      (unless (eobp)
        (queue-enqueue string-q (buffer-substring (point) (point-max))))
      (if (not (eq (car istack) :end))
          (setf (nrepl-response-queue-stub response-q) (cdr istack))
        (queue-enqueue response-q (cadr istack))
        (setf (nrepl-response-queue-stub response-q) nil))
      (erase-buffer)
      (cons string-q response-q))))


;;; Encoding

(defun nrepl--bencode-dict (dict)
  "Encode DICT with bencode.
According to the Bittorrent protocol specification[1], when bencoding
dictionaries, keys must be strings and appear in sorted order (sorted as
raw strings, not alphanumerics).

[1] https://www.bittorrent.org/beps/bep_0003.html#bencoding"
  (mapconcat (lambda (k)
               (concat (nrepl-bencode k)
                       (nrepl-bencode (nrepl-dict-get dict k))))
             (sort (nrepl-dict-keys dict) #'string<)
             ""))

(defun nrepl-bencode (object)
  "Encode OBJECT with bencode.
Integers, lists and nrepl-dicts are treated according to bencode
specification.  Everything else is coerced to a string via `format' and
encoded as such."
  (cond
   ((integerp object) (format "i%de" object))
   ((nrepl-dict-p object) (format "d%se" (nrepl--bencode-dict object)))
   ((listp object) (format "l%se" (mapconcat #'nrepl-bencode object "")))
   (t (let ((s (if (stringp object) object (format "%s" object))))
        (format "%s:%s" (string-bytes s) s)))))

(provide 'nrepl-bencode)

;;; nrepl-bencode.el ends here
