;;; bbs-fetch.el --- BBS Login and Fetch to org-mode
;;
;;; Copyright (C) 2020 Kyle W T Sherman
;;
;; Author: Kyle W T Sherman <kylewsherman at gmail dot com>
;; Created: 2020-09-20
;; Version: 1.0
;; Keywords: bbs telnet
;;
;; This file is not part of GNU Emacs.
;;
;; This is free software; you can redistribute it and/or modify it under the
;; terms of the GNU General Public License as published by the Free Software
;; Foundation; either version 2, or (at your option) any later version.
;;
;; This is distributed in the hope that it will be useful, but WITHOUT ANY
;; WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
;; FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
;; details.
;;
;; You should have received a copy of the GNU General Public License along
;; with GNU Emacs; see the file COPYING. If not, write to the Free Software
;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;;
;;; Commentary:
;;
;; ???
;; Provides `bbs-fetch', `bbs-fetch-select', `bbs-fetch-file-dir',
;; `bbs-fetch-dired', and `bbs-fetch-dired-remote' functions to help creating
;; Emacs menus.
;;
;;; Installation:
;;
;; Put `bbs-fetch.el' where you keep your elisp files and add something like
;; the following to your .emacs file:
;;
;; (require 'bbs-fetch)
;;
;;; Usage:
;;
;; ???
;; The `bbs-fetch' function creates a new menu. You pass it a name and a list
;; of items. Each item is either: 1) a list contianing a name, function, and
;; help text, or 2) a sub-menu containing a name and a list of items. This
;; functionality recurses so you can have n-depth sub-menus.
;;
;; The `bbs-fetch-select' function is similar to `bbs-fetch' except that it
;; opens the menu in a buffer and prompts the user to select an item. It also
;; does not use keymaps and can handle lambda functions. This function is
;; good to use in other functions that need to prompt the user with a list of
;; options to select from.
;;
;; The `bbs-fetch-file-dir' function creates a new menu based on a given
;; directory. It creates an entry for every file matching a pattern (defaults
;; to `.*') and applies a function to it (defaults to `find-file'). There is
;; also an option to recurse through sub-directories or not (defaults to no).
;;
;; The `bbs-fetch-file' function creates a new menu of `find-file' commands.
;; It creates an entry for every file given.
;;
;; The `bbs-fetch-dired' function creates a new menu of `dired' commands. It
;; creates an entry for every directory given.
;;
;; The `bbs-fetch-dired-remote' function creates a new menu of `dired'
;; commands to connect with remote servers. It takes a list of servers and
;; users and creates a menu of servers that each lead to sub-menus of users
;; that when selected will open a dired buffer at that location.
;;
;; Some examples from my configuration (edited for size):
;;
;; ;; dired menu
;; (bbs-fetch
;; "Dired"
;; (bbs-fetch-dired '(("home" . "~/")
;; (".emacs.d" . "~/.emacs.d")
;; (".elisp" . "~/.elisp")
;; ("clojure" . "~/clojure")
;; ("clisp" . "~/clisp")
;; ("bin" . "~/bin"))))
;;
;; ;; load menu
;; (bbs-fetch
;; "Load"
;; `(("Restore Context" "(context-restore)" "Restore previous context save.")
;; ("Home Files..."
;; ,(bbs-fetch-file '((".profile" . "~/.profile")
;; (".bashrc" . "~/.bashrc"))))
;; ("Emacs Settings..."
;; ,(append '((".emacs" "(find-file \"~/.emacs\")" "Load `~/.emacs' file."))
;; (bbs-fetch-file-dir "~/.emacs.d" "\\.el$" "find-file")))
;; ("Elisp Files..."
;; ,(bbs-fetch-file-dir "~/.emacs.d" "\\.el$" "find-file" t))
;; ("Clojure Files..."
;; ,(bbs-fetch-file-dir "~/clojure" "\\.clj$" "find-file" t))
;; ("CLisp Files..."
;; ,(bbs-fetch-file-dir "~/clisp" "\\.lisp$" "find-file" t))
;; ("Org Files..."
;; ,(bbs-fetch-file-dir "~/org" "\\.\\(org\\|org\\.cpt\\)$" "find-file" t))))
;;
;; ;; run menu
;; (bbs-fetch
;; "Run"
;; '(("Emacs Server" "server-start-maybe" "Restart Emacs server.")
;; ("Visit TAGS" "(when (file-exists-p \"~/TAGS\") (visit-tags-table \"~/TAGS\"))" "Visit tags table.")
;; ("IELM Mode" "ielm" "Open buffer for interactively evaluating Emacs Lisp expressions.")
;; ("SLIME Mode" "slime" "Start SLIME mode for interactively evaluating CLISP expressions.")
;; ("Evaluate Current Buffer" "eval-buffer" "Run eval-buffer on the current buffer.")
;; ("Evaluate Current SLIME Buffer" "slime-eval-buffer" "Run slime-eval-buffer on the current buffer.")
;; ("Compile ~/.elisp Directory" "compile-elisp" "Byte compile `~/.elisp' directory.")
;; ("Customize Group" "customize-group" "Run customize group function.")
;; ))
;;
;;; Code:
(defun l29-get-last-message-id ()
"Return last message id in archive."
(let ((buffer-name "level-29-bbs.org"))
(unless (string= (buffer-name) buffer-name)
(error "Buffer is not '%s'" buffer-name))
(save-mark-and-excursion
(save-match-data
(goto-char (point-min))
(unless (re-search-forward "^[ \t]*:CUSTOM_ID: messages$" nil :noerror)
(error "Messages section not found in buffer '%s'!" buffer-name))
(goto-char (point-max))
(if (re-search-backward "^[ \t]*:CUSTOM_ID: message-\\([0-9]+\\)$" nil :noerror)
(string-to-number (match-string 1))
0)))))
(defun l29-send-string (process string &optional with-cr)
"Send STRING to `comint' PROCESS in a way that works with telnet.
If WITH-CR is non-nil, then a carrage return will be added to the end."
(process-send-string process (concat string (if with-cr "\r" ""))))
(defun l29-parse-message (archive-buffer)
"Get message in current buffer and add it to ARCHIVE-BUFFER.
POINT should be at the end of the message.
If the message is a reply, then it will be inserted as a
subheading under the original message.
Message header should look like:
Message #NUM
Subject: SUBJECT
SUBJECT CAN WRAP [optional]
From: NAME
Date: YYYY-MM-DD HH:MM:SS
Connection: DESCRIPTION [optional]
Replying to: NAME, message #NUM [optional]
MESSAGE
Select: ..."
(save-mark-and-excursion
(let ((end (progn
(forward-line -1)
(point))))
(when (re-search-backward "^==========*\n\nMessage" nil :noerror)
(forward-line 2)
(when (looking-at "^Message #\\([0-9]+\\)$")
(let ((message-id (string-to-number (match-string-no-properties 1)))
(start (point))
properties)
(forward-line 1)
(while (re-search-forward "^\\(.*?\\):[ \t]*\\(.*\\)$" (point-at-eol) :noerror)
(let ((property (upcase (replace-regexp-in-string " " "_" (match-string-no-properties 1))))
(value (match-string-no-properties 2)))
(forward-line 1)
(while (looking-at "^[\t ]+\\(.*\\)$")
(setq value (concat value " " (match-string-no-properties 1)))
(forward-line 1))
(push (cons property value) properties)))
(forward-line 1)
(let* ((message (buffer-substring-no-properties start end))
(subject (remove-if-not (lambda (x) (string= (car x) "SUBJECT")) properties))
(reply (remove-if-not (lambda (x) (string= (car x) "REPLYING_TO")) properties))
(reply-id (and reply
(string-to-number
(replace-regexp-in-string "^.* message #" "" (cdar reply))))))
(with-current-buffer archive-buffer
(goto-char (point-max))
(let* ((reply-indent
(if reply-id
(progn
(re-search-backward (format ":CUSTOM_ID: message-%d$" reply-id))
(org-show-entry)
(- (+ (point) 2) (point-at-bol)))
4))
(header (make-string (1- reply-indent) ?*))
(spacer (make-string reply-indent ? )))
(when reply-id
(let ((pos (point)))
(org-forward-heading-same-level 1 :invisible-ok)
(while (and (< (point) pos)
(> (org-outline-level) 1))
(outline-up-heading 1 :invisible-ok)
(org-forward-heading-same-level 1 :invisible-ok)))
(if (= (org-outline-level) 1)
(goto-char (point-max))
(forward-line -1)))
(newline)
(insert (format "%s %d%s\n" header message-id (if subject (concat " - " (cdar subject)) "")))
(insert (format "%s:PROPERTIES:\n" spacer))
(insert (format "%s:CUSTOM_ID: message-%d\n" spacer message-id))
(mapcar (lambda (x) (insert (format "%s:%s: %s\n" spacer (car x) (cdr x))))
(nreverse properties))
(insert (format "%s:END:\n" spacer))
(forward-line -1)
(org-indent-drawer)
(forward-line 1)
(newline)
(insert (replace-regexp-in-string "^\*" "," message)) ; lines starting with asterisk need to be escaped with a coma in org-mode
(let ((point (point)))
(while (invisible-p point)
(goto-char point)
(org-show-entry))))))
(setq l29-last-message-id message-id)))))))
(defun l29-output-filter (process string)
"Output incoming data to process buffer."
(with-current-buffer (process-buffer process)
(let* ((last-insertion (marker-position (process-mark process)))
(delta (- (point) last-insertion))
(input-end (and comint-last-input-end
(marker-position comint-last-input-end)))
(window (get-buffer-window (current-buffer)))
(window-start (and window (window-start window))))
(goto-char last-insertion)
(insert string)
(set-marker comint-last-output-start last-insertion)
(set-marker (process-mark process) (point))
(when window-start
(set-window-start window window-start :noforce))
(when input-end
(set-marker comint-last-input-end input-end))
(while (progn (skip-chars-backward "^\C-m" last-insertion)
(> (point) last-insertion))
(delete-region (1- (point)) (point)))
(goto-char (process-mark process))
(when (> delta 0)
(goto-char (+ (process-mark process) delta))))))
(defun l29-state-filter (process string)
"State based filter.
Possible states:
:login - Perform initial login
:init - Start initial message fetching
:init-next - Continue fetching initial messages
:new - Handle new message fetching
:new-next - Continuefetching new messages
:logout - Perform final logout
BUFFER is used internally for recursive calls."
(let* ((env (expand-file-name "~/.level-29-bbs-login"))
(username (shell-command-to-string (concat "sed -n 's/username=//p' " env)))
(password (shell-command-to-string (concat "sed -n 's/password=//p' " env)))
(case-fold-search t))
(with-current-buffer (process-buffer process)
(l29-output-filter process string)
(let ((point (point)))
(goto-char (point-at-bol))
(case l29-state
;; login and navigate to main prompt
(:login
(cond
((looking-at "^User: $")
(goto-char point)
(l29-send-string process username))
((looking-at "^Password: $")
(goto-char point)
(l29-send-string process password)
(clear-this-command-keys))
((looking-at "^Terminal size .*: $")
(goto-char point)
(l29-send-string process "80x100" :with-cr))
((looking-at "^Terminal type .*: $")
(goto-char point)
(l29-send-string process "dumb" :with-cr))
((looking-at "^Character set .*: $")
(goto-char point)
(l29-send-string process "ASCII" :with-cr))
((looking-at "^Select: \\[.*\\] $")
(goto-char point)
;; move to state based on l29-mode
(setq l29-state l29-mode)
(l29-state-filter process ""))))
;; check for linked messages not in this archive
(:init
(cond
((looking-at "^Select: \\[.*#.*\\] $")
(goto-char point)
(l29-send-string process "#"))
((looking-at "^Go to message number: $")
(goto-char point)
(l29-send-string
process
(number-to-string (if (< l29-last-message-id 2) 2 l29-last-message-id))
:with-cr))
((looking-at "^Select: \\[\\(.*\\)\\] $")
(let ((options (match-string-no-properties 1)))
;; if starting with an empty archive, parse the first message
;; otherwise, last-message-id will have already been parsed
(when (< l29-last-message-id 2)
(l29-parse-message l29-archive-buffer))
(goto-char point)
(if (string-match "e" options)
(progn
(setq l29-state :init-next)
(l29-send-string process "e"))
(progn
(setq l29-state :new)
(l29-send-string process "q")))))))
;; parse all linked messages and add them to this archive
(:init-next
(cond
((looking-at "^Select: \\[\\(.*\\)\\] $")
(let ((options (match-string-no-properties 1)))
(l29-parse-message l29-archive-buffer)
(goto-char point)
(if (string-match "e" options)
(l29-send-string process "e")
(progn
(setq l29-state :new)
(l29-send-string process "q")))))))
;; check for new messages not in this archive
(:new
(cond
((looking-at "^Select: \\[\\(.*\\)\\] $")
(let ((options (match-string-no-properties 1))
(messages (not (re-search-backward "There are 0 unread messages" nil :no-error))))
(goto-char point)
(if (and (string-match "n" options)
messages)
(progn
(setq l29-state :new-next)
(l29-send-string process "n"))
(progn
(setq l29-state :logout)
(if (string-match "q" options)
(l29-send-string process "q")
(l29-state-filter process ""))))))))
;; parse all new messages and add them to this archive
(:new-next
(cond
((looking-at "^Select: \\[\\(.*\\)\\] $")
(let ((options (match-string-no-properties 1)))
(l29-parse-message l29-archive-buffer)
(goto-char point)
(if (string-match "n" options)
(l29-send-string process "n")
(progn
(setq l29-state :logout)
(if (string-match "q" options)
(l29-send-string process "q")
(l29-state-filter process ""))))))))
;; manual
(:manual
(cond
((looking-at "^Select: \\[\\([^#]*\\)\\] $")
(let ((options (match-string-no-properties 1)))
(l29-parse-message l29-archive-buffer)
(goto-char point)))
(t
(goto-char point))))
;; logout
(:logout
(cond
((looking-at "^Select: \\[\\(.*\\)\\] $")
(goto-char point)
(l29-send-string process "o"))
((looking-at "^Really log off\\? ")
(goto-char point)
(set-process-filter process #'l29-output-filter)
(l29-send-string process "y"))))
(otherwise
(goto-char point)))))))
(defun l29-fetch-messages (mode)
"Telnet into <<host>>, fetch new messages, and add them to this archive.
Where MODE is one of:
:init Initialize archive by pulling down all linked messages
:new Pull down new messages
:manual Login then fetch any messages manually viewed by the user"
(interactive)
(let* ((host "<<host>>")
(port <<port>>)
(buffer-name "<<archive-buffer-name>>")
(buffer (current-buffer))
(comint-program "<<program>>")
(comint-name "<<process-name>>")
(comint-buffer "<<process-buffer-name>>")
(last-message-id (l29-get-last-message-id)))
(unless (string= (buffer-name) buffer-name)
(error "Buffer is not '%s'" buffer-name))
;; delete leftover process, if there is one
(when (get-process comint-name)
(delete-process (get-process comint-name)))
(make-comint-in-buffer comint-name comint-buffer comint-program)
(switch-to-buffer-other-window comint-buffer)
(let ((comint-process (get-buffer-process comint-buffer)))
(with-current-buffer comint-buffer
(set (make-local-variable 'l29-archive-buffer) buffer-name)
(set (make-local-variable 'l29-last-message-id) last-message-id)
(set (make-local-variable 'l29-mode) mode)
(set (make-local-variable 'l29-state) :login)
(set-process-filter comint-process #'l29-state-filter)
(accept-process-output comint-process)
(erase-buffer)
(comint-simple-send comint-process (concat "open " host " " (number-to-string port)))))))
(defun l29-fetch-messages-new ()
"Call `l29-fetch-messages' in init mode to pull down all linked
messages. This should only be run once."
(interactive)
(l29-fetch-messages :init))
(defun l29-fetch-messages-new ()
"Call `l29-fetch-messages' in new mode to pull down new
messages."
(interactive)
(l29-fetch-messages :new))
(defun l29-fetch-messages-manual ()
"Call `l29-fetch-messages' in manual mode to login then fetch
any messages manually viewed by the user."
(interactive)
(l29-fetch-messages :manual))
(defun l29-stop-process ()
"Stop the `l29-fetch-messages' process."
(interactive)
(set-process-filter (get-buffer-process "<<process-buffer-name>>") #'l29-output-filter))
;; (defun l29-post-message (&optional reply-id)
;; "Prompt user to write a message, then telnet into <<host>> and post it.
;; If optional REPLY-ID is non-nil, then reply to that message
;; instead of posting a new one."
;; (interactive)
;; (save-mark-and-excursion
;; (let ((message
;; (if reply-id
;; (with-current-buffer archive-buffer
;; (goto-char (point-max))
;; (let* ((reply-indent
;; (re-search-backward (format ":CUSTOM_ID: message-%d$" reply-id))
;; (org-show-entry)
;; (- (+ (point) 2) (point-at-bol)))
;; (header (make-string (1- reply-indent) ?*))
;; (spacer (make-string reply-indent ? )))
;; (if reply-number
;; (save-mark-and-excursion
;; (goto-char (point-max))
;; (re-search-backward "^[ \t]*:CUSTOM_ID: message-\\([0-9]+\\)$")
;; (let ((x (1- (string-to-number (match-string-no-properties 1)))))
;; (while (re-search-backward (format "^[ \t]*:CUSTOM_ID: message-%d$" x) nil :noerror)
;; (goto-char (point-max))
;; (setq x (1- x)))
;; x)))
(defun l29-find-missing-messages ()
"Find missing messages."
(interactive)
(let ((messages (make-hash-table :test 'eq))
max
missing
(ignore '(6012 6014)))
(save-mark-and-excursion
(goto-char (point-min))
(re-search-forward "^[ \t]*:CUSTOM_ID: messages$")
(while (re-search-forward "^[ \t]*:CUSTOM_ID: message-\\([0-9]+\\)$" nil :noerror)
(let ((id (string-to-number (match-string-no-properties 1))))
(puthash id id messages)
(setq max id)))
(do ((id 1 (1+ id)))
((> id max))
(unless (or (gethash id messages)
(< id 4000) ; only start looking for missing ids greater than 4000
(member id ignore))
(push id missing))))
(let ((buffer "*Level 29 Missing Messages*"))
;; setup buffer
(get-buffer-create buffer)
(set-buffer buffer)
(setq buffer-read-only nil)
(erase-buffer)
;; insert header
(insert "Level 29 Missing Messages")
(newline)
(newline)
;; insert table header
(insert "|----------|")
(newline)
(insert "| Messages |")
(newline)
(insert "|----------|")
(newline)
;; insert data
(seq-do
(lambda (id)
(insert (format "| %s |" id))
(newline))
(nreverse missing))
;; insert table footer
(insert "|----------|")
(newline)
;; set mode
(org-mode)
;; align table
(forward-line -2)
(org-table-align)
;; set buffer to read-only
(setq buffer-read-only t)
;; switch to buffer
(switch-to-buffer buffer)
(goto-char (point-min)))))
(defun l29-post-stats ()
"Output statistics on posting frequency."
(interactive)
(let ((post-frequency (make-hash-table :test 'equal)))
(save-mark-and-excursion
(goto-char (point-min))
(re-search-forward "^[ \t]*:CUSTOM_ID: messages$")
(while (re-search-forward "^[ \t]*:FROM: +\\(.*\\)$" nil :noerror)
(let* ((user (match-string 1))
(posts (or (gethash user post-frequency) 0)))
(puthash user (1+ posts) post-frequency))))
(let ((buffer "*Level 29 Post Statistics*"))
;; setup buffer
(get-buffer-create buffer)
(set-buffer buffer)
(setq buffer-read-only nil)
(erase-buffer)
;; insert header
(insert "Level 29 Post Statistics")
(newline)
(newline)
;; insert table header
(insert "|------|-------|")
(newline)
(insert "| User | Posts |")
(newline)
(insert "|------|-------|")
(newline)
;; insert data
(maphash
(lambda (key value)
(insert (format "| %s | %s |" key value))
(newline))
post-frequency)
;; insert table footer
(insert "|------|-------|")
(newline)
;; set mode
(org-mode)
;; align table
(forward-line -2)
(org-table-align)
;; sort table by number of posts, decrementing
(org-table-next-field)
(org-table-next-field)
(org-table-sort-lines nil ?N)
;; set buffer to read-only
(setq buffer-read-only t)
;; switch to buffer
(switch-to-buffer buffer)
(goto-char (point-min)))))
(provide 'bbs-fetch)
;;; bbs-fetch.el ends here