sbbs.el

;;; Code:

(require 'tabulated-list)
(require 'button)
(require 'url)
(require 'hl-line)
(require 'rx)

 ;; CUSTOMIZABLE DATA

(defgroup sbbs nil
  "SchemeBBS client."
  :group 'applications
  :prefix "sbbs-")

(defcustom sbbs-boards
  '(("textboard.org" ("sol" "prog") nil))
  "List of SchemeBBS sites and boards."
  :type '(repeat (list (string :tag "Board Domain")
                       (repeat (string :tag "Board Name"))
                       (boolean :tag "Use TLS?"))))

(defcustom sbbs-jump-to-link t
  "Jump to first link after narrowing posts."
  :type 'boolean)

(defface sbbs--spoiler-face
  '((((background light)) :background "black" :foreground "black")
    (((background dark)) :background "white" :foreground "white"))
  "Face for spoiler text in threads.")

(defface sbbs--code-face

See `sbbs-make-board'.")

(defvar-local sbbs--thread-id nil
  "Buffer local reference to current thread id.

Used in thread and reply buffers.")

(defvar-local sbbs--limit-stack nil
  "Stack of last limit specs.")

 ;; BOARD OBJECT AND FUNCTIONS

(defun sbbs-make-board (domain name &optional tls)
  "Create board object, using DOMAIN, NAME and TLS flag."
  (vector domain name tls))

  (let ((board (or board sbbs--board)))
    (format "%s://%s/%s%s/%s"
            (sbbs--board-protocol board)
            (sbbs--board-domain board)
            (if api-p "sexp/" "")
            (sbbs--board-name board)
            (or path ""))))

(defun sbbs--list-boards ()
  (let (boards)
    (dolist (ent sbbs-boards)
      (dolist (board (cadr ent))
        (push (sbbs-make-board (car ent) board (caddr ent))
              boards)))
    boards))

(defun sbbs-read-board ()
  "Read in a board using `completing-read'.

The list will be generated using `sbbs-boards', and the result
will be a board object generated with `sbbs-make-board'."
  (let (boards)
    (dolist (ent sbbs-boards)
      (dolist (board (cadr ent))
        (push (cons (format "/%s/ (%s)" board (car ent))
                    (sbbs-make-board (car ent) board (caddr ent)))
              boards)))
    (dolist (b (sbbs--list-boards))
      (push (cons (format "/%s/ (%s)"
                          (sbbs--board-name b)
                          (sbbs--board-domain b))
                  b)
            boards))
    (cdr (assoc (completing-read "Board: " boards nil t) boards))))

 ;; UTILITY FUNCTIONS

(defun sbbs--reload-thread (&optional _ignore-auto _noconfirm)
  "Function to reload an opened thread."
  (when sbbs--thread-id (sbbs-view-open sbbs--thread-id)))

(defun sbbs--reload-board ()
  "Function to regenerate thread index.

Called by `tabulated-list-mode' hooks."
  (when sbbs--board (sbbs-browse sbbs--board t)))

(defun sbbs--parse-number-range (desc limit)
  "Generate list of numbers, as specified by DESC.

To avoid memory overflows, limit number of entries to LIMIT."
  (save-match-data
    (apply #'nconc
		   (mapcar
		    (lambda (range)
			  (cond ((string-match "\\`\\([[:digit:]]+\\)-\\([[:digit:]]+\\)\\'" range)
				     (number-sequence (string-to-number (match-string 1 range))
                                      (min limit (string-to-number (match-string 2 range)))))
				    ((string-match "\\`\\([[:digit:]]+\\)\\'" range)
				     (list (string-to-number (match-string 1 range))))
				    (t (error "invalid range"))))
		    (split-string desc ",")))))

(defun sbbs--read-jump-to (nr)
  "Set point to first character of post with number NR."
  (let ((up (point-min)) (down (point-max)) current)
    (while (progn
             (goto-char (+ up (/ (- down up) 2)))
             (setq current (get-text-property (point) 'sbbs-thread-nr))
             (/= nr current))
      (cond ((< nr current) (setq down (point)))
            ((> nr current) (setq up (point))))))
  (unless (and (eq 'highlight (get-text-property (point) 'face))
               (looking-at-p "\\`#[[:digit:]]+"))
    ;; in case we are on the first character of a post, we shouldn't
    ;; jump back, since that would mean setting to point to NR-1.
    (sbbs-read-previous 1)))

 ;; UI GENERATOR

(defconst sbbs--link-regexp
  (rx-to-string
   `(: bos
       (or (: "/" (group-n 2 (+ alnum))
              "/" (group-n 3 (+ digit))
              "/" (group-n 4 (: (+ digit) (? "-" (+ digit)))
                           (* "," (+ digit) (? "-" (+ digit)))))
           (: "http" (? "s") "://"
              (group-n 1 (or ,@(mapcar #'sbbs--board-domain
                                       (sbbs--list-boards))))
              "/" (group-n 2 (+ alnum))
              "/" (group-n 3 (+ digit))
              (? "#t" (backref 3)
                 "p" (group-n 4 (+ digit)))))
       eos))
  "Regular expression to destruct internal links.")

(defun sbbs--limit-to-range (spec &optional no-push-p)
  "Hide all posts in the current thread, that aren't in SPEC.

Unless NO-PUSH-P is non-nil, SPEC will be pushed onto
`sbbs--limit-stack', as to be popped off again by
`sbbs-show-pop'."
  (let ((inhibit-read-only t))
    (remove-list-of-text-properties
     (point-min) (point-max) '(invisible intangible))
    (when spec
      (unless no-push-p
        (push (cons (point) spec) sbbs--limit-stack))
      (save-excursion
        (let ((last (point-max)))
          (goto-char last)
          (while (not (bobp))
            (sbbs-read-previous 1)
            (unless (memq (get-text-property (point) 'sbbs-thread-nr)
                          spec)
              (add-text-properties
               (point) last '(invisible t intangible t)))
            (setq last (point)))))
      (goto-char (point-min))
      (when spec
        (sbbs--read-jump-to (car spec)))
      (let ((point (point)))
        (when sbbs-jump-to-link
          (forward-button 1)
          (when (invisible-p (point))
            (goto-char point)))))))

(defun sbbs--insert-link (text link)
  "Insert link to LINK as TEXT into buffer.

If LINK is a (board, thread or site) local link, modify opening
behaviour accordingly."
  (save-match-data
    (let ((match (string-match sbbs--link-regexp link))
          range id)
      (when match
        (when (match-string 4 link)
          (setq range (sbbs--parse-number-range (match-string 4 link) 300)))
        (setq id (string-to-number (match-string 3 link))))
      (let* ((board sbbs--board)
  (let ((domain (sbbs--board-domain sbbs--board))
        (name (sbbs--board-name sbbs--board))
        (id sbbs--thread-id)
             (domain (sbbs--board-domain board))
             (name (sbbs--board-name board))
             (other (sbbs-make-board (match-string 1 link)
        (local-re "\\`/%s/%d/\\([[:digit:]]+\\)")
        (thread-re "\\`/%s/\\([[:digit:]]+\\)")
        (board-re "\\`http\\(s?\\)://\\([-._[:alnum:]]+\\)/sexp/\\([[:alnum:]]+\\)/\\([[:digit:]]+\\)"))
    (save-match-data
      (cond ((string-match (format local-re name id) link)
                                     (match-string 2 link)
                                     (string-match-p "\\`https://" link)))
             (insert-button
              text
              'action (lambda (x)
             (func (lambda (&optional _)
                        (goto-char (point-min))
                        (sbbs-read-next (1- (button-get x 'sbbs-post-id))))
              'sbbs-post-id (string-to-number (match-string 1 link))))
            ((string-match (format thread-re name id) link)
             (insert-button
                     (cond ((not match) (browse-url link))
                           ;; other supported board
                           ((or (and (sbbs--board-domain other)
                                     (not (string= (sbbs--board-domain other)
                                                   domain)))
                                (not (string= name (sbbs--board-name other))))
                            (let ((sbbs--board other))
              text
              'action (lambda (x)
                        (sbbs-view-open (button-get x 'sbbs-link-id)))
                              (sbbs-view-open id range)))
              'sbbs-link-id (string-to-number (match-string 1 link))))
            ((string-match (format board-re domain name) link)
             (insert-button
                           ;; other thread
              text
              'action (lambda (x)
                        (let ((sbbs--board (button-get x 'sbbs-board)))
                          (sbbs-view-open (button-get x 'sbbs-link-id))))
              'sbbs-board (sbbs-make-board (match-string 2 link)
                           ((/= id sbbs--thread-id)
                            (let ((sbbs--board board))
                              (sbbs-view-open id range)))
                           ;; this thread
                           (range (sbbs--limit-to-range range))))))
                                           (match-string 3 link)
                                           (string= (match-string 1 link) "s"))
              'sbbs-link-id (string-to-number (match-string 3 link))))
            (t (insert-button
        (insert-button text 'action func)))))
                text
                'action (lambda (x) (browse-url (button-get x 'url)))
                'url link))))))

(defun sbbs--insert-sxml-par (sxml)
  "Insert paragraph contents SXML at point."
  (dolist (it sxml)
    (cond ((stringp it)
           (insert (propertize it 'face 'variable-pitch)))
          ((eq (car it) 'br)

Load results into buffer BUF. STATUS is used to check for
errors."
  (when (buffer-live-p buf)
    (when (plist-get status :error)
      (error "Error while loading: %s"
             (cdr (plist-get status :error))))
    (forward-paragraph)
    (decode-coding-region (point-min) (point-max) 'utf-8)
    (forward-paragraph)
    (let ((list (read (current-buffer))))
      (kill-buffer)
      (with-current-buffer buf
        (let (ent)
          (dolist (thread list)
            (push (list (car thread)
                        (vector (substring (cdr (assq 'date (cdr thread)))
                                           0 16)
                                (number-to-string
                                 (cdr (assq 'messages (cdr thread))))
                                (propertize
                                 (cdr (assq 'headline (cdr thread)))
                                 'face 'variable-pitch)))
                  ent))
          (setq-local tabulated-list-entries ent)
          (tabulated-list-print t t)
          (hl-line-highlight))))))

(defun sbbs--thread-loader (status id buf)
(defun sbbs--thread-loader (status id buf range)
  "Callback function for `url-retrieve' when loading thread.

The attribute ID determines what thread from board BOARD to
load. STATUS is used to check for errors."
  (when (buffer-live-p buf)
    (when (plist-get status :error)
      (error "Error while loading: %s"

          (erase-buffer)
          (setq header-line-format
                (format "Thread %d: %s" id
                        (cdr (assq 'headline thread))))
          (dolist (post (cadr (assq 'posts thread)))
            (sbbs--thread-insert-post post))
          (delete-blank-lines)
          (when range
            (sbbs--limit-to-range range))
          (goto-char (point-min)))))))

 ;; INTERACTIVE FUNCTIONS

(defun sbbs-show-all ()
  "Show all hidden posts."
  (interactive)
  (sbbs-show-pop -1))

(defun sbbs-show-pop (&optional n)
  "Show all hidden posts.

A prefix argument N, repeats this N times. If negative or zero,
pop all the way up."
  (interactive "P")
  (let ((n (or n 1)))
    (dotimes (_ (if (> n 0) n (length sbbs--limit-stack)))
      (let ((point (car (pop sbbs--limit-stack))))
        (sbbs--limit-to-range (cdar sbbs--limit-stack) t)
        (when point (goto-char point))))))

(defun sbbs-view-open (id)
(defun sbbs-view-open (id &optional range)
  "Open thread ID in new buffer."
  (interactive (list (tabulated-list-get-id)))
  (let ((url (sbbs--board-url (format "/%d" id) t))
        (headline (or (and (not (tabulated-list-get-entry))
                           header-line-format)
                      (substring-no-properties
                       (aref (tabulated-list-get-entry) 2))))
        (board sbbs--board)
        (buf (get-buffer-create
              (format "*reading /%s/%d*"
                      (sbbs--board-name sbbs--board)
                      id))))
    (with-current-buffer buf
      (sbbs-read-mode)
      (when headline
        (setq header-line-format (format "Thread %d: %s" id headline)))
      (setq sbbs--board board
            sbbs--thread-id id))
    (url-retrieve url #'sbbs--thread-loader (list id buf))
    (url-retrieve url #'sbbs--thread-loader (list id buf range))
    (switch-to-buffer buf)))

(defun sbbs-view-compose ()
  "Create buffer to start a new thread."
  (interactive)
  (let ((board sbbs--board))
    (with-current-buffer (generate-new-buffer "*new thread*")

(defun sbbs-read-next (arg)
  "Move point ARG posts forward."
  (interactive "p")
  (dotimes (_ arg)
    (end-of-line)
    (catch 'found
      (while (search-forward-regexp "^#" nil t)
        (when (eq 'highlight (get-text-property (point) 'face))
        (when (and (eq 'highlight (get-text-property (point) 'face))
                   (not (get-text-property (point) 'invisible)))
          (throw 'found t)))))
  (beginning-of-line))

(defun sbbs-read-previous (arg)
  "Move point ARG posts backwards."
  (interactive "p")
  (dotimes (_ arg)
    (catch 'found
      (while (search-backward-regexp "^#" nil t)
        (when (eq 'highlight (get-text-property (point) 'face))
        (when (and (eq 'highlight (get-text-property (point) 'face))
                   (not (get-text-property (point) 'invisible)))
          (throw 'found t)))))
  (beginning-of-line))

;;;###autoload
(defun sbbs-browse (board reload)
  "Open thread overview for BOARD."
  (interactive (list (sbbs-read-board) nil))

  (let ((map (make-sparse-keymap)))
    (suppress-keymap map)
    (define-key map (kbd "<tab>") #'forward-button)
    (define-key map (kbd "<backtab>") #'backward-button)
    (define-key map (kbd "r") #'sbbs-read-reply)
    (define-key map (kbd "n") #'sbbs-read-next)
    (define-key map (kbd "p") #'sbbs-read-previous)
    (define-key map (kbd "a") #'sbbs-show-pop)
    (define-key map (kbd "A") #'sbbs-show-all)
    map))

(define-derived-mode sbbs-read-mode special-mode "SchemeBBS Read"
  "Major mode for reading a thread."
  (buffer-disable-undo)
  (visual-line-mode t)
  (setq-local revert-buffer-function #'sbbs--reload-thread))