;;; sbbs.el --- SchemeBBS client -*- lexical-binding: t -*-
;; Author: Philip K. <philip@warpmail.net>
;; Version: 0.1.0
;; Keywords: comm
;; Package-Requires: ((emacs "24.4"))
;; URL: https://git.sr.ht/~zge/sbbs
;; 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?")))
:risky t)
(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 sbbs--ornamentum nil
"Global cache of the ornamentum, used for posting.")
;; 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)))
;; 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)
(fill-paragraph)
(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."
(when (plist-get status :error)
(message "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)))
(switch-to-buffer buf)
(hl-line-highlight)))
(defun sbbs--thread-loader (status board id)
"Callback function for `url-retrieve' when loading thread.
The attribute ID determines what thread from board BOARD to
load."
(when (plist-get status :error)
(message "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)))
(buf (get-buffer-create
(format "*reading /%s/%d*"
(sbbs--board-name board)
id))))
(kill-buffer)
(with-current-buffer buf
(sbbs-read-mode)
(setq sbbs--board board
sbbs--thread-id id)
(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))))
(switch-to-buffer buf)))
;; 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)))
(url-retrieve url #'sbbs--thread-loader
(list sbbs--board id))))
(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] 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 to next thread header."
(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 to previous thread header."
(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)
"Open thread overview for BOARD."
(interactive (list (sbbs-read-board)))
(let* ((name (format "*browsing /%s/*" (sbbs--board-name board)))
(url (sbbs--board-url "list" t board)))
(with-current-buffer (get-buffer-create name)
(let ((buffer-read-only nil))
(erase-buffer))
(sbbs-view-mode)
(setq sbbs--board board)
(url-retrieve url #'sbbs--board-loader
(list (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