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