sbbs.el

Artifact [c864d8c09d]
Login

Artifact c864d8c09db7badc2ab5377f9257950f8d615801eb94ee41888611ee95d04307:


;;; sbbs.el --- SchemeBBS client -*- lexical-binding: t -*-

;; Version: 0.1.0
;; Keywords: comm
;; Package-Requires: ((emacs "24.4"))

;; This file is NOT part of Emacs.
;;
;; This file is in the public domain, to the extent possible under law,
;; published under the CC0 1.0 Universal license.
;;
;; For a full copy of the CC0 license see
;; https://creativecommons.org/publicdomain/zero/1.0/legalcode

;;; Commentary:
;;
;; sbbs is a SchemeBBS (https://textboard.org) client in Emacs.
;;
;; Start browsing a board by invoking M-x `sbbs'.

;; Open a board

;;; 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)

(defcustom sbbs-recenter-to-top t
  "Move point to top of frame when moving through 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
  '((((background light)) :background "gray89")
    (((background dark)) :background "gray11"))
  "Face for code blocks in threads.")

 ;; VARIABLES

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

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))

(defsubst sbbs--board-domain (board)
  "Get domain part of a BOARD object."
  (aref board 0))

(defsubst sbbs--board-name (board)
  "Get board name part of a BOARD object."
  (aref board 1))

(defsubst sbbs--board-protocol (board)
  "Determine protocol to be used for BOARD object."
  (if (aref board 2) "https" "http"))

(defun sbbs--board-url (&optional path api-p board)
  "Generate URL for BOARD to access PATH.

If API-P is non-nil, prefix path with \"sexp\"."
  (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 (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)
             (domain (sbbs--board-domain board))
             (name (sbbs--board-name board))
             (other (sbbs-make-board (match-string 1 link)
                                     (match-string 2 link)
                                     (string-match-p "\\`https://" link)))
             (func (lambda (&optional _)
                     (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))
                              (sbbs-view-open id range)))
                           ;; other thread
                           ((/= id sbbs--thread-id)
                            (let ((sbbs--board board))
                              (sbbs-view-open id range)))
                           ;; this thread
                           (range (sbbs--limit-to-range range))))))
        (insert-button text 'action func)))))

(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)
           (newline))
          ((eq (car it) 'b)
           (insert (propertize (cadr it) 'face '(bold variable-pitch))))
          ((eq (car it) 'i)
           (insert (propertize (cadr it) 'face '(italic variable-pitch))))
          ((eq (car it) 'code)
           (insert (propertize (cadr it) 'face 'fixed-pitch)))
          ((eq (car it) 'del)
           (insert (propertize (cadr it) 'face 'sbbs--spoiler-face)))
          ((eq (car it) 'a)
           (let* ((text (caddr it))
                  (link (plist-get (cadadr it) 'href)))
             (sbbs--insert-link text link)))
          (t (insert (prin1-to-string it)))))
  (insert ?\n))

(defun sbbs--insert-sxml (sxml)
  "Insert top level SXML into buffer at point."
  (dolist (par sxml)
    (cond ((eq (car par) 'p)
           (sbbs--insert-sxml-par (cdr par)))
          ((eq (car par) 'blockquote)
           (let ((start (point))
                 (comment-start "> "))
             (sbbs--insert-sxml-par (cdadr par))
             (comment-region start (point))
             (add-face-text-property start (point)
                                     'font-lock-comment-face)))
          ((eq (car par) 'pre)
           (let ((start (point)))
             (insert (propertize (cadadr par)
                                 'face 'fixed-pitch))
             (newline)
             (add-face-text-property start (point) 'sbbs--code-face)))
          (t (error "Unknown top-level element")))
    (insert ?\n)))

(defun sbbs--thread-insert-post (post)
  "Prepare and Insert header and contents of POST at point."
  (let ((start (point)))
    (insert (format "#%d\t%s" (car post)
                    (cdr (assq 'date (cdr post)))))
    (when (cdr (assq 'vip (cdr post)))
      (insert " (VIP)"))
    (newline 2)
    (add-text-properties start (1- (point)) '(face highlight))
    (set-text-properties (1- (point)) (point) nil)
    (sbbs--insert-sxml (cdr (assq 'content (cdr post))))
    (add-text-properties start (point) (list 'sbbs-thread-nr (car post)))))

 ;; URL.EL CALLBACKS

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

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))))
    (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 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"
             (cdr (plist-get status :error))))
    (prog-mode)
    (forward-paragraph)
    (decode-coding-region (point) (point-max) 'utf-8)
    (save-excursion
      (save-match-data
        (while (search-forward "#f" nil t)
          (unless (cadddr (syntax-ppss))
            (replace-match "nil")))))
    (save-excursion
      (save-match-data
        (while (search-forward "#f" nil t)
          (unless (cadddr (syntax-ppss))
            (replace-match "t")))))
    (let ((thread (read (current-buffer))))
      (kill-buffer)
      (with-current-buffer buf
        (let ((buffer-read-only nil))
          (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 &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 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*")
      (sbbs-compose-mode)
      (setq sbbs--board board)
      (switch-to-buffer (current-buffer)))))

(defun sbbs-read-reply (arg)
  "Create buffer to start a reply in current thread.

With \\[universal-argument] interactivly, or a non-nil ARG, add a
reply reference to thread at point."
  (interactive "P")
  (let ((id sbbs--thread-id)
        (nr (get-text-property (point) 'sbbs-thread-nr))
        (board sbbs--board))
    (with-current-buffer (generate-new-buffer "*new response*")
      (sbbs-compose-mode)
      (when (and arg (= (car arg) 4))
        (insert (format ">>%d" nr))
        (newline))
      (setq header-line-format (format "Responding to Thread %d" id)
            sbbs--thread-id id
            sbbs--board board)
      (switch-to-buffer (current-buffer)))))

(defun sbbs-compose-create ()
  "Upload response or thread to board."
  (interactive)
  (let ((board sbbs--board)
        (url-request-method "POST")
        (url-request-extra-headers
         '(("Content-Type" . "application/x-www-form-urlencoded")))
        (url-request-data
         (url-build-query-string
          `((epistula ,(buffer-string))
            (ornamentum "") (name "") (message "")
            (frontpage ,(if sbbs--thread-id "true" "false"))
            . ,(and (not sbbs--thread-id)
                    `((titulus ,(read-string "Headline: ")))))))
        (url (if sbbs--thread-id
                 (sbbs--board-url (format "%d/post" sbbs--thread-id))
               (sbbs--board-url "/post"))))
    (url-retrieve url (lambda (status buf)
                        (if (plist-get status :error)
                            (message "Error while submitting: %s"
                                     (cdr (plist-get status :error)))
                          (kill-buffer buf)
                          (let ((sbbs--board board))
                            (sbbs--reload-thread))))
                  (list (current-buffer)))))

(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 (and (eq 'highlight (get-text-property (point) 'face))
                   (not (get-text-property (point) 'invisible)))
          (throw 'found t)))))
  (beginning-of-line)
  (when sbbs-recenter-to-top
    (set-window-start (selected-window) (point))))

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

;;;###autoload
(defun sbbs-browse (board reload)
  "Open thread overview for BOARD."
  (interactive (list (sbbs-read-board) nil))
  (let* ((name (format "*browsing /%s/*" (sbbs--board-name board)))
         (url (sbbs--board-url "list" t board)))
    (if (and (get-buffer name) (not reload))
        (progn (switch-to-buffer name)
               (sbbs--reload-board))
      (with-current-buffer (get-buffer-create name)
        (sbbs-view-mode)
        (setq sbbs--board board)
        (url-retrieve url #'sbbs--board-loader
                      (list (current-buffer)))
        (switch-to-buffer (current-buffer))))))

;;;###autoload
(defalias 'sbbs #'sbbs-browse)

 ;; MAJOR MODES

(defvar sbbs-view-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "RET") #'sbbs-view-open)
    (define-key map (kbd "c") #'sbbs-view-compose)
    map))

(define-derived-mode sbbs-view-mode tabulated-list-mode "SchemeBBS Browse"
  "Major mode for browsing a SchemeBBS board."
  (buffer-disable-undo)

  (setq tabulated-list-format [("Date" 16 t)
                               ("#" 3 t :right-align t)
                               ("Headline" 0 nil)]
        tabulated-list-sort-key '("Date" . t))
  (add-hook 'tabulated-list-revert-hook
            #'sbbs--reload-board nil t)
  (tabulated-list-init-header)

  (hl-line-mode t))

(defvar sbbs-read-mode-map
  (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))

(defvar sbbs-compose-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "C-c C-c") #'sbbs-compose-create)
    map))

(define-derived-mode sbbs-compose-mode text-mode "SchemeBBS Compose"
  "Major mode for composing replies and starting new threads."
  (setq-local fill-column most-positive-fixnum)
  (message "Press C-c C-c to send"))

(provide 'sbbs)

;;; sbbs.el ends here