sbbs.el

sbbs.el at [e61fee62a1]
Login

File sbbs.el artifact 17e6e6e90b part of check-in e61fee62a1


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

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

(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.")

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

 ;; UI GENERATOR

(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."
  (let ((domain (sbbs--board-domain sbbs--board))
        (name (sbbs--board-name sbbs--board))
        (id sbbs--thread-id)
        (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)
             (insert-button
              text
              'action (lambda (x)
                        (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
              text
              'action (lambda (x)
                        (sbbs-view-open (button-get x 'sbbs-link-id)))
              'sbbs-link-id (string-to-number (match-string 1 link))))
            ((string-match (format board-re domain name) link)
             (insert-button
              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)
                                           (match-string 3 link)
                                           (string= (match-string 1 link) "s"))
              'sbbs-link-id (string-to-number (match-string 3 link))))
            (t (insert-button
                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)
           (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))))
    (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)
  "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)
    (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)
          (goto-char (point-min)))))))

 ;; INTERACTIVE FUNCTIONS

(defun sbbs-view-open (id)
  "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))
    (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 (eq 'highlight (get-text-property (point) 'face))
          (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))
          (throw 'found t)))))
  (beginning-of-line))

;;;###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)
    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."
  (message "Press C-c C-c to send"))

(provide 'sbbs)

;;; sbbs.el ends here