loop/srv
1
0
Fork 0
Code Issues Pull requests Activity

Disables the NNTP repl command when --disables-nntp-repl is given.

Browse source
This commit is contained in:
Circling Skies 2024-12-21 11:21:29 -03:00
parent a89e088212
commit 3850c72b6d
6 changed files with 162 additions and 106 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
accounts.lisp
View file

@ -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))

2
format-def
View file

@ -16,7 +16,7 @@ usage()
sed -E '/^\(defun |\(defmacro /{
i\
}' $* | sed '/^[ \t]*$/{
}' "$@" | sed '/^[ \t]*$/{
N
/^[ \t]*\n$/D
}'

2
loop.asd
View file

@ -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)

53
loop.lisp
View file

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

200
loop.nw
View file

@ -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.
@
<<Version>>=
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.
<<Commands head, body, article>>=
(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.
<<Command post>>=
(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.
<<Command repl>>=
(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.
<<Global variable that decides whether to enable the NNTP REPL>>=
(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.
<<Reference to the database>>=
(defvar *default-database* nil)
(defparameter *default-database* nil)
@ %def *default-database*
<<How to create and connect to the index>>=
@ -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
@<<cron-remove-inactive-users.lisp@>> 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.
<<cron-remove-inactive-users.lisp>>=
<<Quicklisp loading preamble>>
@ -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!]].
<<How to 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.)
<<How to migrate accounts without a creation date>>=
(defun loop-epoch ()
@ -2916,6 +2951,7 @@ something to think about.
@ %def
<<Global variables>>=
(defparameter *debug* nil)
<<Representation of accounts>>
<<Representation of a client>>
<<Representation of requests and responses>>
@ -2923,7 +2959,7 @@ something to think about.
<<Representation of commands>>
<<Representation of articles>>
<<Definition of maximum allowed inactive periods>>
(defvar *debug* nil)
<<Global variable that decides whether to enable the NNTP REPL>>
@
On which packages do we depend?
@ -2942,7 +2978,7 @@ The \lp\ system definition:
:description "<<Description>>"
:depends-on (<<List of packages to be loaded>>)
:components ((:file "loop")))
@ %def :loop loop.asd
@
\section*{Index of chunks}
\nowebchunks

4
make-release
View file

@ -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 "/<<Version>>=/ {
n;
c\\
$tag
}" $*
}" "$@"