From 3850c72b6d8640c03146a48f98ffe47d4eea4574 Mon Sep 17 00:00:00 2001 From: Circling Skies Date: Sat, 21 Dec 2024 11:21:29 -0300 Subject: [PATCH] Disables the NNTP repl command when --disables-nntp-repl is given. --- accounts.lisp | 7 +- format-def | 2 +- loop.asd | 2 +- loop.lisp | 53 ++++++++----- loop.nw | 200 +++++++++++++++++++++++++++++--------------------- make-release | 4 +- 6 files changed, 162 insertions(+), 106 deletions(-) diff --git a/accounts.lisp b/accounts.lisp index 9a6401c..e1b49ff 100644 --- a/accounts.lisp +++ b/accounts.lisp @@ -1,9 +1,10 @@ (#S(LOOP::ACCOUNT :USERNAME "ROOT" - :SEEN 3943637447 + :SEEN 3943778307 :LAST-POST NIL :FRIENDS NIL - :PASS NIL + :PASS #(166 101 164 89 32 66 47 157 65 126 72 103 239 220 79 184 160 74 31 + 63 255 31 160 126 153 142 134 247 247 162 122 227) :PASS-LOCKED NIL :PASS-LOCKED-WHY NIL - :CREATION 3913066800)) + :CREATION 3913066800)) \ No newline at end of file diff --git a/format-def b/format-def index af80142..ba7be7a 100644 --- a/format-def +++ b/format-def @@ -16,7 +16,7 @@ usage() sed -E '/^\(defun |\(defmacro /{ i\ -}' $* | sed '/^[ \t]*$/{ +}' "$@" | sed '/^[ \t]*$/{ N /^[ \t]*\n$/D }' diff --git a/loop.asd b/loop.asd index e4fea15..53ffc6b 100644 --- a/loop.asd +++ b/loop.asd @@ -1,6 +1,6 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*- (asdf:defsystem :LOOP - :version "afe7d0e" + :version "a89e088" :description "An NNTP server for a circle of friends." :depends-on (:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon :filesystem-utils :ironclad/digest/sha256) diff --git a/loop.lisp b/loop.lisp index 1b831ff..c9cd3ef 100644 --- a/loop.lisp +++ b/loop.lisp @@ -17,19 +17,20 @@ (in-package #:loop) +(defparameter *debug* nil) (defstruct account username seen last-post friends pass pass-locked pass-locked-why creation) (defparameter *accounts* nil) (defstruct client group (article 1) (username "ANONYMOUS") (auth? 'no)) (defparameter *client* (make-client)) (defstruct request verb args said) (defstruct response code data request multi-line) -(defvar *default-database* nil) +(defparameter *default-database* nil) (defstruct command fn verb description) (defparameter *commands-assoc* nil) (defstruct article headers body) (defparameter *months-inactive-allowed* 3) (defparameter *months-never-logged-in* 1) -(defvar *debug* nil) +(defparameter *enable-nntp-repl* t) (defun table-of-commands () `(("GROUP" ,#'cmd-group "sets the current group") @@ -843,7 +844,7 @@ (defun menu (ls) (loop for item in ls - collect (display-fn (car ls)))) + collect (display-fn item))) (defun display-fn (cmd-pair) (let ((cmd (cdr cmd-pair))) @@ -935,16 +936,18 @@ (defun cmd-post (r) (with-auth (send-response! - (make-response :code 340 - :data (format nil "Okay, go ahead. Suggested message-id ~a." + (make-response + :code 340 + :data (format nil "Okay, go ahead. Suggested message-id ~a." (suggest-message-id)))) (let* ((bs (nntp-read-article))) (multiple-value-bind (okay? error) (conforms? bs) - (if (not okay?) - (make-response :code 400 :request r - :data (format nil "Sorry. Your article doesn't conform: ~a." error)) - (multiple-value-bind (code reply) (post bs) - (make-response :code code :request r :data reply))))))) + (cond ((not okay?) + (make-response + :code 400 :request r + :data (format nil "Sorry. Your article doesn't conform: ~a." error))) + (t (multiple-value-bind (code reply) (post bs) + (make-response :code code :request r :data reply)))))))) (defun post (bs) (let ((ngs (newsgroups-header->list @@ -1282,8 +1285,13 @@ (make-response :code 200 :data (format nil "state: ~a" *client*) :request r)) (defun cmd-repl (r) - (with-auth - (repl r))) + (if *enable-nntp-repl* + (with-auth + (repl r)) + (make-response + :code 400 + :data "The REPL has been *explicitly* disabled by the sysadmin. :(" + :request r))) (defun notify-group-created (g) (post-notification @@ -1338,10 +1346,15 @@ :key :list-accounts) (clingon:make-option :flag - :description "runs a REPL" + :description "runs a REPL right now" :short-name #\r :long-name "repl" :key :repl) + (clingon:make-option + :flag + :description "disables the NNTP REPL" + :long-name "disable-nntp-repl" + :key :disable-nntp-repl) (clingon:make-option :flag :description "logging (on stderr)" @@ -1392,12 +1405,16 @@ (connect-index! "message-id.db") (create-index!) (let ((args (clingon:command-arguments cmd)) + (run-server t) (repl (clingon:getopt cmd :repl)) (ca (clingon:getopt cmd :create-account)) (pa (clingon:getopt cmd :change-passwd)) (la (clingon:getopt cmd :list-accounts)) - (logging (clingon:getopt cmd :logging))) + (logging (clingon:getopt cmd :logging)) + (disable-nntp-repl (clingon:getopt cmd :disable-nntp-repl))) (setf *debug* logging) + (when (or ca pa la) + (setf run-server nil)) (when la (cli/list-accounts)) (when ca @@ -1406,14 +1423,16 @@ (cli/change-passwd pa args)) (when repl (repl (make-request :verb "repl" :args '(command-line)))) - (when (and (not la) (not ca) (not pa) (not repl)) + (when disable-nntp-repl + (setq *enable-nntp-repl* nil)) + (when run-server (server-start)))) (defun cli/command () (clingon:make-command :name "loop" :description "An NNTP server for a circle of friends." - :version "afe7d0e" + :version "a89e088" :license "GPL v3" :options (cli/options) :handler #'cli/main-with-handlers)) @@ -1443,7 +1462,7 @@ (send-response! (make-response :code 200 - :data "Welcome! I am LOOP afe7d0e. Say ``help'' for a menu."))) + :data "Welcome! I am LOOP a89e088. Say ``help'' for a menu."))) (setq lisp-unit:*print-failures* t) (define-test dispatching diff --git a/loop.nw b/loop.nw index d28f1c7..85014f9 100644 --- a/loop.nw +++ b/loop.nw @@ -47,6 +47,7 @@ {a circle out of fashion}} \date{January 2024} \begin{document} +\pdfbookmark[1]{Introduction}{intro} \fontfamily{cmr}\selectfont \maketitle %\setlength{\parskip}{3pt} @@ -54,9 +55,9 @@ \Lp\ is an out-of-fashion program, used as medium of communication by antiquated people. \Lp\ members insist that technical communication -be made in writing and not in a hurry. That's how backwards they are. -To give you an idea, they write \Lp\ in Lisp---jurassic technology. -We surely wouldn't pay them any attention. +be made in writing and not in a hurry. To give you an idea, they +write \Lp\ in jurassic technology. You wouldn't pay them any +attention. % \begin{verbatim} Drunk and dressed in their best brown baggies and their platform soles @@ -74,6 +75,24 @@ the list of destinaries. So long as everyone replies to everyone, John, too, will start getting all the messages. If anyone violates this rule of replying to everyone involved, the loop is broken. +%% \begin{figure}[!htb] +%% \centering \includegraphics[width=0.8\linewidth]{images/gnus-summary.png} +%% \caption{Gnus, a news reader embedded in the GNU EMACS text editor.} +%% \label{fg:gnus} +%% \end{figure} +%% +%% \begin{figure}[!htb] +%% \centering \includegraphics[width=0.8\linewidth]{images/tbird-summary.png} +%% \caption{Thunderbird, a news reader produced by the Mozilla Foundation.} +%% \label{fg:bird} +%% \end{figure} +%% +%% \begin{figure}[!htb] +%% \centering \includegraphics[width=0.8\linewidth]{images/sylpheed-summary.png} +%% \caption{Sylpheed, a news reader produced by Hiroyuki Yamamoto.} +%% \label{fg:sylpheed} +%% \end{figure} + There are surely inconveniences in using e-mail as conference medium. For example, after John has been added to the loop, he is not able to leave by his own account. He needs to ask everyone involved to stop @@ -118,41 +137,23 @@ NNTP-aware programs. You could write your own. Figures \ref{fg:gnus}--\ref{fg:sylpheed} show a few programs for reading network news via NNTP. -\begin{figure}[!htb] - \centering \includegraphics[width=0.8\linewidth]{images/gnus-summary.png} - \caption{Gnus, a news reader embedded in the GNU EMACS text editor.} - \label{fg:gnus} -\end{figure} - -\begin{figure}[!htb] - \centering \includegraphics[width=0.8\linewidth]{images/tbird-summary.png} - \caption{Thunderbird, a news reader produced by the Mozilla Foundation.} - \label{fg:bird} -\end{figure} - -\begin{figure}[!htb] - \centering \includegraphics[width=0.8\linewidth]{images/sylpheed-summary.png} - \caption{Sylpheed, a news reader produced by Hiroyuki Yamamoto.} - \label{fg:sylpheed} -\end{figure} - -\noindent{\bf Principles for a discussion group}. We believe a discussion group +\pdfbookmark[1]{Principles for a discussion group}{principles} +\label{principles} +{\bf Principles for a discussion group}. We believe a discussion group should be small and grow slowly. By ``slowly'', we mean that each member comes in through an invitation. This way, the group being closed by definition, we keep spam out and give members a certain -sense of privilege. - -A discussion group should be formed by interested people. If a -participant doesn't log-in for a certain period of time, \lp locks the -participant's account---see Section \ref{sec:inactive-users}. The -account can be reactivated, but it will take asking another -participant (with an active account) to do so. In other words, -there's an encouragement for an uninterested member not to come back -to the \lp. The idea is to keep a certain cohesion in the discussion -groups. When an account is locked or unlocked, an article is posted -to the group {\tt local.control.news}, so everyone knows who is -leaving and arriving. This way, participants get to have an idea of -who is reading them. +sense of privilege. A discussion group should be formed by interested +people. If a participant doesn't log-in for a certain period of time, +\lp locks the participant's account---see Section +\ref{sec:inactive-users}. The account can be reactivated, but it will +take asking another participant (with an active account) to do so. In +other words, there's an encouragement for an uninterested member not +to come back to the \lp. The idea is to keep a certain cohesion in +the discussion groups. When an account is locked or unlocked, an +article is posted to the group {\tt local.control.news}, so everyone +knows who is leaving and arriving. This way, participants get to have +an idea of who is reading them. Each invitation comes with a certain responsibility: it's possible to see who invited who. If {\tt BOB} misbehaves, everyone gets to see @@ -658,7 +659,7 @@ An NNTP server for a circle of friends. @ <>= -afe7d0e +a89e088 @ \section{Parsing of requests} @@ -709,10 +710,15 @@ we need to is to implement a new option. The library is extensible. :key :list-accounts) (clingon:make-option :flag - :description "runs a REPL" + :description "runs a REPL right now" :short-name #\r :long-name "repl" :key :repl) + (clingon:make-option + :flag + :description "disables the NNTP REPL" + :long-name "disable-nntp-repl" + :key :disable-nntp-repl) (clingon:make-option :flag :description "logging (on stderr)" @@ -776,12 +782,16 @@ service starts with [[server-start]]. (connect-index! "message-id.db") (create-index!) (let ((args (clingon:command-arguments cmd)) + (run-server t) (repl (clingon:getopt cmd :repl)) (ca (clingon:getopt cmd :create-account)) (pa (clingon:getopt cmd :change-passwd)) (la (clingon:getopt cmd :list-accounts)) - (logging (clingon:getopt cmd :logging))) + (logging (clingon:getopt cmd :logging)) + (disable-nntp-repl (clingon:getopt cmd :disable-nntp-repl))) (setf *debug* logging) + (when (or ca pa la) + (setf run-server nil)) (when la (cli/list-accounts)) (when ca @@ -790,7 +800,9 @@ service starts with [[server-start]]. (cli/change-passwd pa args)) (when repl (repl (make-request :verb "repl" :args '(command-line)))) - (when (and (not la) (not ca) (not pa) (not repl)) + (when disable-nntp-repl + (setq *enable-nntp-repl* nil)) + (when run-server (server-start)))) (defun cli/command () @@ -980,7 +992,7 @@ reason to think we're doing to debug it.} (defun menu (ls) (loop for item in ls - collect (display-fn (car ls)))) + collect (display-fn item))) (defun display-fn (cmd-pair) (let ((cmd (cdr cmd-pair))) @@ -1555,7 +1567,15 @@ XXX: instead of only catching [[sb-posix:syscall-error]], we should catch anything else, reporting the error. Otherwise, we will blow up in case of some unexpected error, which might not be a bad idea---as long as we can log these errors and get a report later on of what's -going on so we can improve the code. +going on so we can improve the code. I still don't really know what +to do here. Let's leave it as it is. The original idea is to put a +[[t]]-case in the [[handler-case]] below and just log the error +instead of crashing completely. We can simulate the catching of an +unexpected condition by signaling it from fetch-article as a test. +This type of situation should have a testing routine as well. So, +yeah, first give yourself another read of the [[lisp-unit]] +documentation, then how to handle conditions properly and then come +back to this to-do item. <>= (defun typical-cmd-response (code r g i get-data) @@ -1775,10 +1795,11 @@ now, however, we have only these two to worry about. (ensure-header "date" #'get-date bs)) @ %def ensure-mid ensure-date -Now it's time to look at the header \verb|newsgroups|. (XXX: Our code -here is a bit confusing, but I don't know the best to do here, so I'm -going ahead unpretentiously.) If we get approved by [[conforms?]], -then we verify the list of newsgroups right away. +Now it's time to look at the header \verb|newsgroups|. XXX: we need +to rewrite this because we have that plan of verifying everything +there is to verify up front in [[conforms?]]. So when we invoke +[[post]], there's nothing else to verify. We're verifying in two +places at the same time. The name of each group must conform to the expression @@ -1801,16 +1822,18 @@ of trying to stop them. (defun cmd-post (r) (with-auth (send-response! - (make-response :code 340 - :data (format nil "Okay, go ahead. Suggested message-id ~a." + (make-response + :code 340 + :data (format nil "Okay, go ahead. Suggested message-id ~a." (suggest-message-id)))) (let* ((bs (nntp-read-article))) (multiple-value-bind (okay? error) (conforms? bs) - (if (not okay?) - (make-response :code 400 :request r - :data (format nil "Sorry. Your article doesn't conform: ~a." error)) - (multiple-value-bind (code reply) (post bs) - (make-response :code code :request r :data reply))))))) + (cond ((not okay?) + (make-response + :code 400 :request r + :data (format nil "Sorry. Your article doesn't conform: ~a." error))) + (t (multiple-value-bind (code reply) (post bs) + (make-response :code code :request r :data reply)))))))) @ It's time to write the action of posting. One thing to keep in mind @@ -1820,14 +1843,14 @@ our index. More to follow.) More importantly, we cannot let the user post to any group if one of the groups is incorrectly named---for example, when the group doesn't exist. Why don't we post to the ones that are correct and warn the user of the ones that are incorrect? -Because that is not prudent. The user could be trying to divulge news +Because that is not prudent. The user could be trying to publish news to be received at the same time by various groups. We would make such -plans all go down the drain. So we don't. +plans all go down the drain. We collect a list of newsgroups that don't exist (or whose names do not conform for any reason). If we find any such group, then we refuse posting and return a 400 code with a message describing which -group names failed. Otherwise we [[save-article-insist]]. +group names failed. Otherwise we save the article. <>= (defun post (bs) @@ -2096,16 +2119,30 @@ all or it has been discussed with the community beforehand. \subsection{{\tt REPL}} \lp\ is totally {\em hackable}. Users can say {\tt repl} to have -complete control over their \lxxp\ process. XXX: we should implement -an option [[--disable-repl]] so that REPL hacking is turned off. -(This would mean your users are not true hackers.) +complete control over their \lxxp\ process. <>= (defun cmd-repl (r) - (with-auth - (repl r))) + (if *enable-nntp-repl* + (with-auth + (repl r)) + (make-response + :code 400 + :data "The REPL has been *explicitly* disabled by the sysadmin. :(" + :request r))) @ +If your users are not the hacker-type, you can disable the NNTP REPL +with the command-line option [[--disable-nntp-repl]]. We decide not +to hide the command in the list of commands given by saying {\tt HELP} +to \lp\ because this way users are advertised about the commands that +exist---they could be having fun, but their sysadmin doesn't think +they're skilled enough. + +<>= +(defparameter *enable-nntp-repl* t) +@ + \section{Publication of news} If you're interested in being notified about what's going on in the @@ -2215,7 +2252,7 @@ working. Since we work with only one, we pretty much never need to specify anything. <>= -(defvar *default-database* nil) +(defparameter *default-database* nil) @ %def *default-database* <>= @@ -2387,16 +2424,15 @@ Index built. \section{Deletion and locking of inactive accounts}\label{sec:inactive-users} -XXX: remove this paragraph from here; present the program first and -then talk about it. In [[remove-friend]], note that [[username]] is -the account name and [[friend]] is the name of the account being -removed. Notice as well that we only know who invited the person -after we can get a hold of the account in [[accounts.lisp]]. This -means we must scan each account to delete an account---we can't delete -an account and still leave the account as someone's friend. - -The program [[cron-remove-inactive-users.lisp]] can be executed every -day at midnight, say. +We now implement some of the principles exposed earlier on +page~\pageref{principles}. The program +@<> would be run by {\tt cron} every +day (at midnight, say). It checks all accounts that are inactive and +either locks them (to be deleted later) or deletes them {\em for + good}. If you want to keep accounts forever, just don't run the +program. XXX: our idea is to also delete {\em for good} all accounts +that are locked (by the same period of time), but we have not yet done +that. <>= <> @@ -2408,15 +2444,12 @@ day at midnight, say. (write-accounts!) @ %def cron-remove-inactive-users.lisp -In [[remove-account]], we probably should use [[delete-if]] as well on -the list of friends since it is effectively what we are doing there -with [[setf]]. %% TODO +The entire program is really [[remove-inactive-users!]]. <>= (defun remove-inactive-users! () (loop for u in *accounts* do (let ((username (account-username u))) - (format t "Username: ~a~%" username) (cond ((and (not (locked? username)) (inactive-from-never-logged-in? username)) (post-notification @@ -2442,10 +2475,10 @@ with [[setf]]. %% TODO To remove an account, we need to first remove the username (to be removed) from anyone's list of friends. So, this involves scanning the entire list of accounts. Also, notice that delete ``may modify -{\em sequence}''. More importantly is to understand tha we really -must {\tt setf} the return, otherwise we might find the deletion did -not take effect---for example, when deleting the first element of a -list. (This deserves a better explanation, but if you know how linked +{\em sequence}''. More important is to understand that we really must +{\tt setf} the return, otherwise we might find the deletion did not +take effect---for example, when deleting the first element of a list. +(XXX: this deserves a better explanation, but if you know how linked lists are implemented in C, say, then you're likely well aware of how it works.) @@ -2469,7 +2502,9 @@ Accounts that do not have a creation date up until today---Tue Sep 17 21:37:18 ESAST 2024---will have its creation dates migrated to the \Lp\ epoch, which is January 1st 2024, the exact month in which \Lp\ was written. But notice that this migration is done only once. -New system administrators of \Lp\ will never need to run this. +New system administrators of \Lp\ will never need to run this. (We do +not remove this set of source code chunks because they serve as an +example of how to a migration like that.) <>= (defun loop-epoch () @@ -2916,6 +2951,7 @@ something to think about. @ %def <>= +(defparameter *debug* nil) <> <> <> @@ -2923,7 +2959,7 @@ something to think about. <> <> <> -(defvar *debug* nil) +<> @ On which packages do we depend? @@ -2942,7 +2978,7 @@ The \lp\ system definition: :description "<>" :depends-on (<>) :components ((:file "loop"))) -@ %def :loop loop.asd +@ \section*{Index of chunks} \nowebchunks diff --git a/make-release b/make-release index 1fb1af5..e75a8ce 100644 --- a/make-release +++ b/make-release @@ -4,11 +4,11 @@ usage() printf 'usage: %s tag file\n' $0 exit 1 } -test $# '<' 2 && usage +test $# -lt 2 && usage tag="$1" shift sed "/<>=/ { n; c\\ $tag -}" $* +}" "$@"