sbbs.el

;;; Directory Local Variables
;;; For more information see (info "(emacs) Directory Variables")

((emacs-lisp-mode
  (tab-width . 4)
  (indent-tabs-mode . nil)))

*.elc
*~
\#*\#

Creative Commons Legal Code

CC0 1.0 Universal

    CREATIVE COMMONS CORPORATION IS NOT A LAW FIRM AND DOES NOT PROVIDE
    LEGAL SERVICES. DISTRIBUTION OF THIS DOCUMENT DOES NOT CREATE AN
    ATTORNEY-CLIENT RELATIONSHIP. CREATIVE COMMONS PROVIDES THIS
    INFORMATION ON AN "AS-IS" BASIS. CREATIVE COMMONS MAKES NO WARRANTIES
    REGARDING THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS
    PROVIDED HEREUNDER, AND DISCLAIMS LIABILITY FOR DAMAGES RESULTING FROM
    THE USE OF THIS DOCUMENT OR THE INFORMATION OR WORKS PROVIDED
    HEREUNDER.

Statement of Purpose

The laws of most jurisdictions throughout the world automatically confer
exclusive Copyright and Related Rights (defined below) upon the creator
and subsequent owner(s) (each and all, an "owner") of an original work of
authorship and/or a database (each, a "Work").

Certain owners wish to permanently relinquish those rights to a Work for
the purpose of contributing to a commons of creative, cultural and
scientific works ("Commons") that the public can reliably and without fear
of later claims of infringement build upon, modify, incorporate in other
works, reuse and redistribute as freely as possible in any form whatsoever
and for any purposes, including without limitation commercial purposes.
These owners may contribute to the Commons to promote the ideal of a free
culture and the further production of creative, cultural and scientific
works, or to gain reputation or greater distribution for their Work in
part through the use and efforts of others.

For these and/or other purposes and motivations, and without any
expectation of additional consideration or compensation, the person
associating CC0 with a Work (the "Affirmer"), to the extent that he or she
is an owner of Copyright and Related Rights in the Work, voluntarily
elects to apply CC0 to the Work and publicly distribute the Work under its
terms, with knowledge of his or her Copyright and Related Rights in the
Work and the meaning and intended legal effect of CC0 on those rights.

1. Copyright and Related Rights. A Work made available under CC0 may be
protected by copyright and related or neighboring rights ("Copyright and
Related Rights"). Copyright and Related Rights include, but are not
limited to, the following:

  i. the right to reproduce, adapt, distribute, perform, display,
     communicate, and translate a Work;
 ii. moral rights retained by the original author(s) and/or performer(s);
iii. publicity and privacy rights pertaining to a person's image or
     likeness depicted in a Work;
 iv. rights protecting against unfair competition in regards to a Work,
     subject to the limitations in paragraph 4(a), below;
  v. rights protecting the extraction, dissemination, use and reuse of data
     in a Work;
 vi. database rights (such as those arising under Directive 96/9/EC of the
     European Parliament and of the Council of 11 March 1996 on the legal
     protection of databases, and under any national implementation
     thereof, including any amended or successor version of such
     directive); and
vii. other similar, equivalent or corresponding rights throughout the
     world based on applicable law or treaty, and any national
     implementations thereof.

2. Waiver. To the greatest extent permitted by, but not in contravention
of, applicable law, Affirmer hereby overtly, fully, permanently,
irrevocably and unconditionally waives, abandons, and surrenders all of
Affirmer's Copyright and Related Rights and associated claims and causes
of action, whether now known or unknown (including existing as well as
future claims and causes of action), in the Work (i) in all territories
worldwide, (ii) for the maximum duration provided by applicable law or
treaty (including future time extensions), (iii) in any current or future
medium and for any number of copies, and (iv) for any purpose whatsoever,
including without limitation commercial, advertising or promotional
purposes (the "Waiver"). Affirmer makes the Waiver for the benefit of each
member of the public at large and to the detriment of Affirmer's heirs and
successors, fully intending that such Waiver shall not be subject to
revocation, rescission, cancellation, termination, or any other legal or
equitable action to disrupt the quiet enjoyment of the Work by the public
as contemplated by Affirmer's express Statement of Purpose.

3. Public License Fallback. Should any part of the Waiver for any reason
be judged legally invalid or ineffective under applicable law, then the
Waiver shall be preserved to the maximum extent permitted taking into
account Affirmer's express Statement of Purpose. In addition, to the
extent the Waiver is so judged Affirmer hereby grants to each affected
person a royalty-free, non transferable, non sublicensable, non exclusive,
irrevocable and unconditional license to exercise Affirmer's Copyright and
Related Rights in the Work (i) in all territories worldwide, (ii) for the
maximum duration provided by applicable law or treaty (including future
time extensions), (iii) in any current or future medium and for any number
of copies, and (iv) for any purpose whatsoever, including without
limitation commercial, advertising or promotional purposes (the
"License"). The License shall be deemed effective as of the date CC0 was
applied by Affirmer to the Work. Should any part of the License for any
reason be judged legally invalid or ineffective under applicable law, such
partial invalidity or ineffectiveness shall not invalidate the remainder
of the License, and in such case Affirmer hereby affirms that he or she
will not (i) exercise any of his or her remaining Copyright and Related
Rights in the Work or (ii) assert any associated claims and causes of
action with respect to the Work, in either case contrary to Affirmer's
express Statement of Purpose.

4. Limitations and Disclaimers.

 a. No trademark or patent rights held by Affirmer are waived, abandoned,
    surrendered, licensed or otherwise affected by this document.
 b. Affirmer offers the Work as-is and makes no representations or
    warranties of any kind concerning the Work, express, implied,
    statutory or otherwise, including without limitation warranties of
    title, merchantability, fitness for a particular purpose, non
    infringement, or the absence of latent or other defects, accuracy, or
    the present or absence of errors, whether or not discoverable, all to
    the greatest extent permissible under applicable law.
 c. Affirmer disclaims responsibility for clearing rights of other persons
    that may apply to the Work or any use thereof, including without
    limitation any person's Copyright and Related Rights in the Work.
    Further, Affirmer disclaims responsibility for obtaining any necessary
    consents, permissions or other rights required for any use of the
    Work.
 d. Affirmer understands and acknowledges that Creative Commons is not a
    party to this document and has no duty or obligation with respect to
    this CC0 or use of the Work.

`sbbs.el`
=========

`sbbs` is a [SchemeBBS][schemebbs] client in Emacs. It implements
browsing the thread list, threads and creating responses.

Any bugs, patches or questions can be submitted to my [public
inbox][mail].

Issues and Improvments
----------------------

- Due to issues with `url.el`, some versions of Emacs take
  quite long to load threads/thread lists.
- No highlighting in response buffers.
- Spoilers aren't shown unless manually highlighted.

Copying
-------

`sbbs.el` is distributed under the [CC0 1.0 Universal (CC0 1.0) Public
Domain Dedication][cc0] license.

[schemebbs]: https://textboard.org/
[public inbox]: https://lists.sr.ht/~zge/public-inbox
[cc0]: https://creativecommons.org/publicdomain/zero/1.0/deed

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