root/loop
1
0
Fork 0
Code Issues Pull requests Activity
loop/loop.nw

3944 lines
154 KiB
Text
Raw Blame History

% -*- mode: poly-noweb; -*-
\documentclass[a4paper,11pt]{article}
\usepackage[text={6.75in,10in},centering]{geometry}
\usepackage{graphicx}
\usepackage{microtype}
\DisableLigatures[-]{family=tt*}
\usepackage[T1]{fontenc}
\usepackage[utf8]{inputenc}
\usepackage[english]{babel}
\usepackage{csquotes}
\usepackage{etoolbox}
\AtBeginEnvironment{quote}{\small}
\AtBeginEnvironment{verbatim}{\small}
%% \usepackage[backend=biber]{biblatex}
%% \addbibresource{refs.bib}
%% \renewcommand{\cite}{\parencite}
% \usepackage[hyperref]{xcolor}
\usepackage[colorlinks=true,citecolor=]{hyperref} % linkcolor=red
\usepackage{amsmath,amsthm,amssymb}
\allowdisplaybreaks
\usepackage{lmodern}
\usepackage{noweb}
\noweboptions{longchunks,smallcode}
\DeclareMathOperator{\mdc}{mdc}
\DeclareMathOperator{\gcdext}{gcdext}
\DeclareMathOperator{\remainder}{remainder}
\DeclareMathOperator{\quotient}{quotient}
\DeclareMathOperator{\diff}{diff}
\def\nwendcode{\endtrivlist \endgroup}
\let\nwdocspar=\par
\usepackage[most]{tcolorbox}
\newtcolorbox{crossedblock}[1][]{
enhanced,
breakable,
colback=gray!5,
colframe=red!60!black,
boxrule=0.8pt,
arc=1mm,
overlay={
\draw[red!60!black, line width=1.5pt, opacity=0.4]
(frame.north west) -- (frame.south east);
\draw[red!60!black, line width=1.5pt, opacity=0.4]
(frame.south west) -- (frame.north east);
},
#1
}
%% Popular words.
\newcommand{\lxxp}{{\tt loop}}
\newcommand{\Lp}{{\tt LOOP}}
\newcommand{\lp}{\Lp}
\newcommand{\bug}{{\em bug}}
\newcommand{\symlink}{{\em symbolic link}}
\newcommand{\symlinks}{\symlink s}
\title{\Lp\\
{a circle out of fashion}}
\date{January 2024}
\begin{document}
\pdfbookmark[1]{Introduction}{intro}
\fontfamily{cmr}\selectfont
\maketitle
%\setlength{\parskip}{3pt}
%\setlength{\parindent}{0pt}
\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, anxiety-free. 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
They don't give a damn about any trumpet-playing band
It ain't what they call rock and roll
-- Mark Knopfler, 1978.
\end{verbatim}
It's easy to make a conference on the Internet: e-mail suffices. When
we write an e-mail to various friends to discuss a certain subject, we
form a circle. When we decide to add another person to this
quickly-made conference by e-mail, sometimes we use a well-known
idiom---``adding John to the loop''. We add John's e-mail address to
the list of destinataries. So long as everyone replies to everyone,
John too will get 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/gnus-article.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}
\begin{figure}[!htb]
\centering \includegraphics[width=0.8\linewidth]{images/sylpheed-reading.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
writing to him. This is usually easy to do, but instead people tend
to ask for more technology such as mailing lists. A mailing list is
nothing but an automated version of this idea of writing to various
people at once. When the mailing address is written to, a program
resends the message to all subscribers of the mailing list and, this
way, the conference takes place.
But \lp\ has nothing to do with e-mail. \Lp\ uses a communication
strategy---called a ``protocol''---that is even older than the web
itself. The web started out around 1989--1990 and the protocol
\lp\ uses begins its history in 1979, the year in which AT\&T released
UNIX V7, which was UUCP-ready, an acronym that stands for ``UNIX to
UNIX copy''. UUCP is both a protocol and a set of programs for
copying files between UNIX systems. People began exchanging messages
by copying files between machines. The idea of using UUCP for
exchanging messages eventually evolved into a protocol called
NNTP---Network News Transfer Protocol---, which is the protocol used
by \lp. (The protocol used to be called Netnews Transfer Protocol.)
Since e-mail was already daily practice of members of the Internet
back then, many things from e-mail were taken by the NNTP designers.
So, an NNTP message looks a lot like an e-mail message and the
two---NNTP and SMTP (the protocol used by e-mail)---can often mingle
seamlessly. The impression we get from using NNTP is that we're
sending e-mail to a certain group of people. It's as though the
message goes into a collective mailbox and anyone interested in that
mailbox reads the messages there. If anyone would like to reply to a
message, they do so and, this way, communication flows among the
interested crowd. If anyone would like to leave the group, nothing is
needed---the person just doesn't go back to read any more messages.
Unlike mailing lists, there is no need to formally commit to reading
one of these collective mailboxes and no need to formally notify
anyone or any system that you're not interested in that group any
longer. These collective mailboxes are called ``news groups'' and are
often written as ``newsgroups''. And the messages posted to these
newsgroups are called ``articles''.
Just like e-mail and the web, network news is an open protocol.
Anyone could write a program capable of speaking NNTP. There are many
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.
\section*{Principles for a discussion group}\label{principles}
\pdfbookmark[1]{Principles for a discussion group}{principles} 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 loop. 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, who is watching them.
Each invitation comes with a certain responsibility: it's possible to
see who invited who. If {\tt BOB} misbehaves, everyone gets to see
that {\tt ALICE} doesn't have nice friends. The {\tt USERS} command
shows the relationship graph:
%
\begin{verbatim}
USERS
200 List of current users:
ANONYMOUS, last seen on Fri Mar 8 19:01:56 2024, invited (ALICE)
ALICE, last seen on Sun Mar 10 21:25:45 2024, invited (BOB CARLA)
BOB, last seen on Sun Mar 10 21:17:30 2024, invited nobody
CARLA, last seen on Sun Mar 10 18:30:48 2024, invited nobody
\end{verbatim}
We conjecture that a discussion group tends to prosper when each
member feels as important as any other member. So we think each
member should have as much managerial power as any other. In an
attempt to realize this ideal, each member is able to not only invite
other people---see the [[CREATE-ACCOUNT]] command---, but also to
create new groups---see the [[CREATE-GROUP]] command.
Despite this introduction, this is not a tutorial on the history of
the Internet or how NNTP works. This is the source code of \lp.
Hereafter, our conversation continues in Lisp. Understanding how
\lp\ is made is only necessary if you intend to modify it. If you
just want to use the system, you probably should stop right here.
\section*{How to install}
See
\href{https://git.atlantida.space/root/loop/raw/branch/main/README}{[[README]]}
in \lp's source code.
\section{Implementation strategy}\label{sec:design}
Anything a user sends to the \lp\ is wrapped in a [[request]] and
any command processing must produce a [[response]]:
%
\begin{verbatim}
request ---> process ---> response.
\end{verbatim}
%
The request arrives, \lp\ interprets it, finds out which command
should look at the request and then dispatches the the request to the
right command. The command process the request and returns a
response. Then \lp\ takes this response and sends it out back to the
user through the network using [[send-response!]]. That's all there
is to \lp. Everything else is just the details of this strategy.
Before you investigate the source code of \lp, you should have {\tt
SBCL} installed---the Common Lisp compiler we've been using---and
the package [[:loop]]. This way you can interact with the system:
%
\begin{verbatim}
CL-USER> (ql:quickload :loop)
To load "loop":
Load 1 ASDF system:
loop
; Loading "loop"
..................
(:LOOP)
CL-USER> (in-package :loop)
#<PACKAGE "LOOP">
LOOP> (make-request "HELP")
#S(REQUEST :VERB "HELP" :ARGS NIL :SAID NIL)
\end{verbatim}
%
The procedure [[make-request]] constructs a [[request]]. When a user
connects to the \lp, each command sent by the user is packaged inside
a [[request]] structure like this one above. To see how \lp\ answers
this request for help, we can invoke the procedure [[dispatch]], which
is responsible to find the correct procedure to reply to the request.
\begin{verbatim}
LOOP> (dispatch (make-request :verb "HELP"))
#S(RESPONSE
:CODE 400
:DATA "unrecognized command"
:REQUEST #S(REQUEST :VERB "HELP" :ARGS NIL :SAID NIL)
:MULTI-LINE NIL)
\end{verbatim}
It turns that \lp\ doesn't recognize the command. That's because we
only loaded the [[:loop]] package. The reason it doesn't recognize
the command is that the command table has not been built. Let's build
it and try again:
\begin{verbatim}
LOOP> (set-up-tables!)
(("ARTICLE"
. #S(COMMAND
:FN #<FUNCTION CMD-ARTICLE>
:VERB "ARTICLE"
:DESCRIPTION "fetches full articles"))
[...]
("HELP"
. #S(COMMAND
:FN #<FUNCTION CMD-HELP>
:VERB "HELP"
:DESCRIPTION "displays this menu")) [...])
LOOP> (dispatch (make-request :verb "HELP"))
#S(RESPONSE
:CODE 200
:DATA (87 104 97 [...] 112)
:REQUEST #S(REQUEST :VERB "HELP" :ARGS NIL :SAID NIL)
:MULTI-LINE YES)
\end{verbatim}
That's better. These numbers we see in the response are the bytes in
the response. You can get a string version of these numbers:
\begin{verbatim}
LOOP> (bytes->string (response-data (dispatch (make-request :verb "HELP"))))
"What's on the menu today?
ARTICLE fetches full articles
AUTHINFO makes me trust you
BODY fetches an article body
GROUP sets the current group
HEAD fetches article headers
HELP displays this menu
LIST lists all groups
MODE handles the mode request from clients
NEXT increments the article pointer
POST posts your article
QUIT politely says good-bye
XDD displays your state of affairs
XOVER fetches the overview database of a group"
\end{verbatim}
This is the text that the user sees when they ask for {\tt HELP}. In
other words, the field {\tt data} in a [[response]] stores the data to
be delivered back to the user. The program {\tt nc}---for
``netcat''---that we use below is capable of opening a TCP connection
and handling that connection to our keyboard so that we can interact
with the \lp. You can effectively achieve the same thing using a
program such as {\tt telnet}.
\begin{verbatim}
C:\>nc nntp.atlantida.space 119
200 Welcome! Say ``help'' for a menu.
help
200 What's on the menu today?
ARTICLE fetches full articles
AUTHINFO makes me trust you
BODY fetches an article body
GROUP sets the current group
HEAD fetches article headers
HELP displays this menu
LIST lists all groups
MODE handles the mode request from clients
NEXT increments the article pointer
POST posts your article
QUIT politely says good-bye
XDD displays your state of affairs
XOVER fetches the overview database of a group
.
quit
205 Good-bye.
\end{verbatim}
Despite \lp\ being made to talk to computer programs such as the ones
illustrated in Figures~\ref{fg:gnus}--\ref{fg:sylpheed}, it's
perfectly possible for a user to interact with \lp\ directly using a
keyboard and a command-line tool such as {\tt nc} or {\tt telnet}. In
fact, \lp\ takes advantage of that to be {\em hackable}---see also
Section~\ref{sec:repl}. Commands such as [[CREATE-ACCOUNT]],
[[CREATE-GROUP]], [[PASSWD]] are not part of the NNTP protocol, so
users need to know how to use {\tt nc} or {\tt telnet} to take
advantage of all of \lp's capabilities.
\section{NNTP protocol}
An Internet protocol is usually defined by a document whose tradition
calls RFC---for ``request for comments''---, an acronym suggested by
Stephen D.~Crocker, who wrote RFC 1 back in 1969, when ARPANET
connected four computers. NNTP is defined by RFCs 977, 2980, 3977,
4643 and 5536. RFC 977 was the first and replaced by 3977. Still,
reading RFC 977 is interesting precisely because it gives us a
historical account of the protocol, making it easier to understand the
evolution of the system. The objective of RFC 2980 was to implement
new ideas to the NNTP protocol---to extend the protocol. RFC 3977
adopts some of these extensions. RFC 4643 also extends RFC
2980---addressing concerns with authentication.
\section{It's a network server}
The \lp\ program is a network server, that is, it serves connections
on the network. However, instead of implementing the handling of TCP
connections, we use what is called a ``TCP superserver'' or ``TCP
wrappers'' or perhaps just ``TCP server''. The idea is---a program
called ``TCP server'' waits for connections from the network. When a
client arrives, the TCP server handles the network connection to \lp.
From \lp's perspective, the client is just another keyboard talking to
it directly. This strategy simplifies the implementation of \lp.
Both programs---the TCP server and \lp---have nothing to do with one
another, but their work together makes the service. This
implementation strategy is typically found in UNIX programs.
%
\begin{quote}\small
This is the Unix philosophy. Write programs that do one thing and do
it well. Write programs to work together. Write programs that handle
text streams, because that is a universal interface.\\ --- Doug
McIlroy, 1989, interviewed by Michael S.~Mahoney.
\end{quote}
%
The TCP server just just one thing---listens for new connections and
handles them to the interested program. It does the handling and does
it well. \Lp, on the other hand, concerns itself with the NNTP
protocol and does not worry about handling network connections. This
way, they work together. And \lp\ handles only a text stream, which
is why it's so easy to connect a keyboard to it and interact with it
through the command line as illustrated in Section~\ref{sec:design}.
\section{REPL for \lp}\label{sec:repl}
There's a REPL to \lp's procedures---always useful.
\begin{verbatim}
%./loop --repl
LOOP> (+ 1 1)
2
LOOP> (list-groups)
(local.control.news local.test)
\end{verbatim}
The REPL can also be use in the middle of an NNTP conversation, which
is useful for debugging. All authenticated users can use it, making
passwords only a barrier to spammers, not to your circle of friends,
since everyone can find a way to log in with anyone's account, change
their passwords or just do whatever they want to \lxxp\ process or
databases.
<<Loop REPL.lisp>>=
(defun repl (r)
(in-package :loop)
(loop
(print/finish "LOOP> ")
(handler-case
(let ((expr (read)))
(if (eq 'quit expr)
(progn
(return
(make-response
:code 200 :request r
:data "Okay, that's enough hacking for today.")))
(println "~a" (eval expr))))
(end-of-file ()
(print/finish "^D~%")
(uiop:quit 0))
(interactive-interrupt ()
(print/finish "^C~%")
(uiop:quit 0))
(t (c)
(print/finish
"Oops: ~a~%"
(str:collapse-whitespaces
(str:replace-all (string #\linefeed) " " (fmt "~a" c))))))))
@ %def repl
\section{Representation of a client}
How do we represent a client? A client is typically reading a group
and an article; it's has authenticated itself or not yet. So we need
a global structure to annonate the client's state.
<<Representation of a client.lisp>>=
(defstruct client group (article 1) (username "ANONYMOUS") (auth? 'no))
(defparameter *client* (make-client))
@ %def client *client*
\section{Representation of a command}
What does a client typically tell \lp? A client typically sends
commands. Commands typically need arguments. Each command is
dispatched to a procedure that answers it---it's the purpose of
\verb|fn| in the command. Together, all commands make up a table of
commands, which is essentially what the user sees when asks for
\verb|HELP|. (Be aware that some clients use the output of
\verb|HELP|. For example, Gnus v5.13.)
<<Representation of commands.lisp>>=
(defstruct command fn verb description)
(defparameter *commands-assoc* nil)
@
<<Table of commands.lisp>>=
(defun table-of-commands ()
`(("GROUP" ,#'cmd-group "sets the current group")
("LISTGROUP" ,#'cmd-listgroup "lists the exact articles a group has")
("NEXT" ,#'cmd-next "increments the article pointer")
("HELP" ,#'cmd-help "displays this menu")
("LIST" ,#'cmd-list "lists all groups")
("LIST NEWSGROUPS" ,#'cmd-list "same as LIST")
("LIST ACTIVE" ,#'cmd-list "same as LIST")
("LIST OVERVIEW.FMT" ,#'cmd-list "lists xover fields")
("CAPABILITIES" ,#'cmd-capabilities "displays our capabilities")
("AUTHINFO" ,#'cmd-authinfo "makes me trust you")
("LOGIN" ,#'cmd-login "shorter interface to AUTHINFO")
("HEAD" ,#'cmd-head "fetches article headers")
("MODE" ,#'cmd-mode "handles the mode request from clients")
("BODY" ,#'cmd-body "fetches an article body")
("POST" ,#'cmd-post "posts your article")
("ARTICLE" ,#'cmd-article "fetches full articles")
("XOVER" ,#'cmd-xover "fetches the overview database of a group")
("XHDR" ,#'cmd-xhdr "fetches a specific header from articles")
("CREATE-GROUP" ,#'cmd-create-group
"creates a new group so you can discuss your favorite topic")
("CREATE-ACCOUNT",#'cmd-create-account
"creates an account so you can invite a friend")
("PASSWD" ,#'cmd-passwd "changes your password")
("USERS" ,#'cmd-list-users "lists all users")
("DD" ,#'cmd-dd "[d]isplays [d]ata: your state of affairs")
("QUIT" ,#'cmd-quit "politely says good-bye")
("DATE" ,#'cmd-date "displays the current date at this server")
("UNLOCK-ACCOUNT" ,#'cmd-unlock-account "unlocks an account")
("REPL" ,#'cmd-repl "lets you hack away")
("SEARCH" ,#'cmd-search "is your search engine")))
(defun set-up-tables! ()
(labels ((build-commands-assoc (ls)
(if (null ls)
nil
(cons (apply #'make-command-pair (car ls))
(build-commands-assoc (cdr ls)))))
(make-command-pair (name fn desc)
(cons name (make-command :fn fn :verb name :description desc))))
(setf *commands-assoc*
(sort
(build-commands-assoc (table-of-commands))
#'string-lessp :key #'car))))
(defun get-command (key)
(let ((cmd (assoc key *commands-assoc* :test #'string=)))
(labels ((unrecognized-command ()
(make-command
:fn #'(lambda (r)
(make-response
:code 400
:data "unrecognized command"
:request r))
:verb 'unrecognized
:description "a command for all commands typed wrongly")))
(or (cdr cmd) (unrecognized-command)))))
@ %def *commands-assoc* set-up-tables! get-command
\section{Representation of requests and responses}
Each command is given through a text line written by the user. Let's
call this text line the [[request]]. When \lp\ parses the request, it
will extract (from the request) a verb and some arguments. We will
take a verbatim copy of everything the user has said, possibly for
debugging purposes.
How do we represent a [[response]]? A [[response]] is always a
reaction to a [[request]]. The NNTP protocol always specifies an
integer as the code to a response, which is what we call the
\verb|code| in the response. Long responses end with a period and we
mark such responses with [[multi-line]].
<<Representation of requests and responses.lisp>>=
(defstruct request verb args said)
(defstruct response code data request multi-line)
@
<<Procedures for requests and responses.lisp>>=
(defun empty-response () (make-response :code 400 :data "I beg your pardon?"))
(defun prepend-response-with (message r)
(make-response
:code (response-code r)
:data (list message (crlf) (response-data r))
:multi-line (response-multi-line r)
:request (response-request r)))
@
\section{Main loop}
Every command consumes a [[request]] and produces a [[response]].
What does \lp\ do as its main loop? It repetitively reads a line from
the user, processes that line and always replies something back. Then
\lp\ is back at waiting for the user to say something else again. If
the user says {\tt QUIT}, then we should identify it and terminate
\lp's execution. That's why [[send-response!]] returns the
[[request]] itself---so we can cascade actions based on a user's
request.
<<Main loop.lisp>>=
(defun main-loop ()
(handler-case
(loop
(let* ((bs (nntp-read-line))
(ln (bytes->string bs)))
(stderr "<<< ~a~%" ln)
(let ((r (send-response! (dispatch-line ln))))
(when (response-quit? r)
(return)))))
(end-of-file (c)
(declare (ignore c))
(stderr "a client disconnected with EOF~%"))
(error (e)
(stderr "fatal: ~A" e))))
@ %def main-loop
<<Main loop.lisp>>=
(defun request-quit? (r) (and r (string= 'quit (request-verb r))))
(defun response-quit? (r) (and r (request-quit? (response-request r))))
(defun server-start ()
(set-up-tables!)
(send-banner!)
(main-loop))
(defun main ()
(let ((app (cli/command)))
(clingon:run app)))
(defun send-banner! ()
(send-response!
(make-response
:code 200
:data (welcome-message))))
(defun welcome-message ()
(cl-ppcre:regex-replace-all "HASH" "<<Welcome message>>" *git-hash*))
@ %def main welcome-message
\noindent It's always useful to know which version exactly we're
dealing with:
%
\begin{verbatim}
%./loop.exe
200 Welcome! I am LOOP 9575ac2. Say ``help'' for a menu.
\end{verbatim}
%
So we put a release tag on \lp's banner.
<<Welcome message>>=
Welcome! I am <<Name>> <<Version>> hash HASH. Say ``help'' for a menu.
@
\noindent We take the opportunity and describe \lp's package,
information which we also use in [[loop.asd]].
<<Name>>=
LOOP
@
<<Description>>=
An NNTP server for a circle of friends.
@
<<Version>>=
0.0.1
@
\section{Parsing of requests}
The commands themselves we call {\tt verbs}; everything else the user
types we call {\tt args}. Observe that upper and lower case letters
are equivalent in request verbs.
<<Procedures for requests and responses.lisp>>=
(defun parse-request (r)
(let* ((collapsed-s (str:collapse-whitespaces (request-said r)))
(ls (str:split " " collapsed-s :omit-nulls 'please)))
;; What are we going to do with a null request?
(cond ((null ls) (make-request :said (request-said r)))
(t (let ((verb (car ls))
(args (cdr ls)))
(make-request :said (request-said r)
:verb (str:upcase verb)
:args args))))))
@ %def parse-request
\section{Parsing of command-line arguments}
We're using the clingon library as per Vincent Dardel suggestion in
``The Common Lisp Cookbook''. We begin with writing a description of
the program and options it understands. Notice I don't know how to
support a two-argument option, so I hacked a solution away. What we
need to do is to implement a new option. The library is extensible.
However, I could be misremembering it here, but I recall having
decided to give up on the clingon library because it does too much. I
think it even handles {\tt SIGINT} on our backs. Nevertheless, do
notice that the library is doing a pretty good for a start, so unless
we understand exactly what it was that we didn't like, we'll keep it.
<<Command-line parsing.lisp>>=
(defun cli/options ()
(list
(clingon:make-option
:string
:description "creates a new account"
:long-name "create-account"
:key :create-account)
(clingon:make-option
:string
:description "changes password"
:long-name "change-passwd"
:key :change-passwd)
(clingon:make-option
:flag
:description "lists accounts"
:short-name #\l
:long-name "list-accounts"
:key :list-accounts)
(clingon:make-option
:flag
: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)"
:long-name "logging"
:key :logging)))
@
We implement first the procedures that handle options that represent
an entire program. For example, saying [[--list-accounts]] is like
running a program [[./list-accounts]].
<<Command-line parsing.lisp>>=
(defun cli/list-accounts ()
(println (str:join (crlf-string) (list-users))))
(defun cli/create-account (username args)
(let ((invited-by (car args)))
(cond ((null invited-by)
(println "Must specify who invites the new account."))
((get-account username)
(println "Username account ``~a'' already exists." username))
((not (get-account invited-by))
(println "Invited-by account ``~a'' doesn't exist." invited-by))
(t
(multiple-value-bind (okay? pass-or-error) (new-account! username invited-by)
(if okay?
(progn (println "Okay, account ``~a'' created with password ``~a''."
username pass-or-error)
(notify-user-created username))
(println "Sorry, ~a." pass-or-error)))))))
(defun cli/change-passwd (username args)
(let* ((random-passwd (random-string 6))
(given-passwd (car args))
(new-passwd (or given-passwd random-passwd)))
(if (not (get-account username))
(println "No such account ``~a''." username)
(multiple-value-bind (okay? problem)
(change-passwd! username new-passwd)
(if okay?
(println "Okay, account ~a now has password ``~a''." username new-passwd)
(println "Sorry, could not change password: ~a." problem))))))
@ %def cli/change-passwd cli/list-accounts cli/create-account
Now let's write the main procedure in command-line parsing. Notice
that because of the design of the [[clingon]] library, command-line
parsing becomes the main procedure of \lp. In other words, \lp's
service starts with [[server-start]].
<<Command-line parsing.lisp>>=
(defun cli/main-with-handlers (cmd)
(handler-case
(cli/main cmd)
(end-of-file ()
(print/finish "^D~%")
(uiop:quit 0))
(interactive-interrupt ()
(print/finish "^C~%")
(uiop:quit 0))))
(defun cli/main (cmd)
(read-accounts!)
(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))
(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
(cli/create-account ca args))
(when pa
(cli/change-passwd pa args))
(when repl
(repl (make-request :verb "repl" :args '(command-line))))
(when disable-nntp-repl
(setq *enable-nntp-repl* nil))
(when run-server
(server-start))))
(defun cli/command ()
(clingon:make-command
:name "loop"
:description "<<Description>>"
:version "<<Version>>"
:license "GPL v3"
:options (cli/options)
:handler #'cli/main-with-handlers))
@ %def cli/options cli/command
\section{Request dispatching mechanism}
Dispatching requests means consuming one and invoking the correct
procedure that will process the request. The invoked procedure must
produce a [[response]]. The work of dispatching is just delivering
the task to an response-producing procedure and then raising the
response to whoever needs to catch it. For example,
[[response-quit?]] is used by [[main-loop]] to identify when the user
has issued {\tt QUIT}, in which case we terminate [[main-loop]].
<<Dispatching of commands.lisp>>=
(defun dispatch (r)
(let* ((verb (request-verb r)))
(if (null verb)
(empty-response)
(funcall (command-fn (get-command verb)) r))))
(defun dispatch-line (ln)
(dispatch (parse-request (make-request :said ln))))
@ %def dispatch dispatch-line
\section{Representation and parsing of articles}
An article is made of two parts, the head and the body. We do need to
parse the head, but we never parse the body: we don't want to
intervene in anything that a user might be doing in the body of the
article; in fact, we don't need read the body in memory because it
might be large. When we need to send an article to a client, we then
read it chunk by chunk and stream it out with constant memory use.
The headers, however, are mostly under the jurisdiction of the server.
This assumption is justified by the fact that servers must understand
headers. For example, how do we know to which groups an article was
posted? We look at the header {\tt newsgroups}. The assumption we
make here is that headers are always one-byte encoded, which is not
the case of ASCII, but it is the case of ISO-8859-1. The procedure
[[code-char]] realizes this ideal, so we're out of trouble here.
So, in the structure below, [[article-head]] is a string, while
[[article-body]] is a vector of bytes. To get a list of pairs out of
the set of all headers of an article, we can ask [[parse-headers]].
<<Representation of articles.lisp>>=
(defstruct article head body)
@ %def article-head article-body
\section{How to parse articles}
We don't extract the entire article from the file system. We first
extract just the headers. If it's ever needed, we read the article's
body chunk by chunk and hand each chunk to a client that asked for it.
Let's focus now on reading the headers. First, we need to read the
bytes off of the file system into memory. What if the article is
huge? We can't read it all. What we do is to read just enough of the
article until we find all of the head. That's the job of
[[read-headers-raw]].
The method below is to assume every head fits in a certain fixed size.
We'll be right nearly 100\% of the time. If we were to find a very
long head, we'll then allocate more and more and crash, which is fine
because a \lp\ process handles just a single client. Ideally, we'd
stop at a certain limit and give up on the article, which is easy to
do: throw an exception if the size of the array goes beyond the limit.
We work with two buffers, the accumulator [[acc]] and the temporary
[[buffer]]. We fill in [[buffer]]. Now we memorize the length of
[[acc]] before we possibly modify its size by copying-extending it.
Now we know the position of where the new chunk of the head has been
allocated. It's time to search just the newly-read chunk for
\verb|\r\n\r\n|. A [[search]] call should do. However, what happens
if a chunk read from the stream ended right in the middle of the
separator? We would be appending the tail of the separator right now,
so we must go back a little bit before we search so that we can find
the separator even in cases when we had to read it in two calls to
[[read-sequence]]. (Such is life in programming.) That's why we
subtract 3 from [[start-search]]. If we don't find the separator
still, that's because the head is really long, so we repeat. When we
find it, we know that the head starts at zero and goes up to the
position of the separator. The job of parsing an article is to
separate head from body; having the head, we know the body starts 4
bytes after the length of the head.
<<How to read the head of articles.lisp>>=
(defun read-headers-raw (path)
(with-open-file (in path :element-type '(unsigned-byte 8) :if-does-not-exist :error)
(let ((acc (make-array 8192
:element-type '(unsigned-byte 8)
:adjustable t :fill-pointer 0))
(buffer (make-array 8192 :element-type '(unsigned-byte 8)))
(sep #(13 10 13 10)))
(loop
(let ((n (read-sequence buffer in)))
(when (zerop n)
(return acc)) ; eof without having found the separator
(let ((start-search (length acc)))
(dotimes (i n) ; copy all bytes to the accumulator
(vector-push-extend (aref buffer i) acc))
;; Search for the separator. We subtract 3 from our
;; start index to catch a separator that was broken into
;; two calls of read-sequence.
(let ((pos (search sep acc :start2 (max 0 (- start-search 3)))))
(when pos
(return (subseq acc 0 pos))))))))))
@ %def read-headers-raw
\section{How to stream off articles through the network}
We consider the body of articles to be the poster's property, so we
don't want to touch it in any way. For example, we never treat it as
a string because we would have to guess an encoding. It's the article
viewer's---the NNTP client's---responsibility of interpreting such
bytes.
For us, articles are made of a string head and a sequence-of-bytes
body. Of great relevance is the fact that some articles could be
huge, so we don't read them wholly into memory. When it's necessary
to send an entire article to a client, we just stream the bytes to the
client chunk by chunk, giving us a constant-memory guarantee. We
describe now how we do this.
You can see in [[parse-article]] that we use a {\em displaced array}.
A displaced array is a great feature of Common Lisp in which a new
array is made but references an already allocated memory. How are
articles handled by LOOP? Begin at [[fetch-article]], which depends
on [[read-headers-raw]], a procedure that reads only so much of an
article so as to consume the entirety of headers, using
[[vector-push-extend]]. So the only way to attack LOOP is to send it
an article whose headers are huge, implying we must limit article's
head size, though we don't currently do that. As soon as headers are
consumed, [[read-headers-raw]] finishes.
Of greater relevance here is [[typical-cmd-response]] because it is
the one that actually streams off bytes to a client. How does it do
it? It first reads the headers and then it marks off where the body
begins. How does it mark the body? By using the structure called
[[file-stream-payload]], our choice of how to represent an article
body. The structure records the path of the file and where in the
streaming it is; the {\em where} is the current byte to be written to
the network, discovered by Lisp's [[file-position]], the portable
version of [[POSIX fseek]]. Where does a body begin? An article is
made of a head, a separator and a body. So the body begins at where
the separator ends. You can verify this information by reading
[[read-headers-raw]].
The product of [[typical-cmd-response]] is a response. When an entire
article has been requested---which is what happens when someone issues
a [[BODY]] or an [[ARTICLE]] command---, [[send-response!]] will need
to read the body's bytes. If you now look at [[send-response!]] you
can see that it delegates the actual work to [[send-chunk!]], which,
in turn, delegates it to [[stream-file-to-socket]], which does the
job. How does it do the job? It knows exactly where the body begins.
It then has only the job of reading a chunk (of fixed sized) of that
file at where the body begins. Then it writes the entire file to the
client's network connection. How does it do it? While it's able to
get bytes from [[read-sequence]], it writes them one by one to the
network socket. Why one one by one? To make sure we can do {\em
dot-stuffing}, otherwise we could've delegated that job to
[[write-sequence]].
Can we do a better job with respect to the source code writing?
Procedure [[send-response!]] needs to do different things based on the
type of content. This desired type-dispatching is performed by
[[send-chunk!]] and then we need to write a particular procedure for
handling the file-stream-payload representation. So, not
really---we've done the best we can here.
{\bf Dot stuffing}. Should dot stuffing be done on the fly? The
alternative would be when storing the article. But, no, we should
store the article precisely as the user has sent it. It is to be
treated as an important historical document. We don't touch user
property, which is the article's body.
{\bf Limit header size}. We need to limit head size otherwise we
could suffer an attack of making us allocate too much memory because
the head never ends. We also need to limit article size, otherwise
we'll fill up the file system. Looking for something to do?
Implement these limits---pretty easy task.
<<How to stream off articles.lisp>>=
(defstruct file-stream-payload
(path "" :type string)
(start-pos 0 :type integer))
(defun fetch-article (g i)
(in-group g
(read-headers-raw (fmt "~a" i))))
(defun stream-file-to-socket (payload out-stream)
"Opens the file, seeks to the start of the body, and streams to the socket
while applying on-the-fly NNTP dot-stuffing."
(with-open-file (in (file-stream-payload-path payload)
:element-type '(unsigned-byte 8))
;; file-position here is doing what ftell(3) in C would do
(file-position in (file-stream-payload-start-pos payload))
(let ((buf (make-array 8192 :element-type '(unsigned-byte 8)))
(at-line-start t))
(loop for n = (read-sequence buf in)
while (plusp n)
do (loop for i from 0 below n
for byte = (aref buf i)
do (when (and at-line-start (= byte 46)) ; 46 is '.'
(write-byte 46 out-stream))
(write-byte byte out-stream)
(setf at-line-start (= byte 10)))))))
(defun send-chunk! (chunk s)
(etypecase chunk
(string (write-sequence (string->bytes chunk) s))
(vector (write-sequence chunk s))
(list (dolist (c chunk) (send-chunk! c s)))
(integer (write-byte chunk s))
(file-stream-payload (stream-file-to-socket chunk s))))
(defun send-response! (r)
(send-chunk! (integer->string (response-code r)) *standard-output*)
(send-chunk! " " *standard-output*)
(send-chunk! (response-data r) *standard-output*)
(send-chunk! (crlf) *standard-output*)
(when (response-multi-line r)
(send-chunk! "." *standard-output*)
(send-chunk! (crlf) *standard-output*))
(force-output)
r)
@ %def read-headers-raw fetch-article
\section{How to parse headers}
The input is a vector of bytes, bytes that represent the article
written on the file system. First, search for the \verb|\r\n\r\n|,
which separates head and body. The headers themselves can be turned
into a string. For the body, we're going to use a great feature of
Common Lisp---a zero-copy array window into the original array [[v]],
the argument of the procedure. The feature is requested by the
[[:displaced-to]] keyword, which specifies the original array, where
our window begins is specified by the long offset keyword. The length
of our window has to be the entire article body, which is the length
of the vector minus the head and the separator \verb|\r\n\r\n|, which
is 4 bytes long.
An article that would have no separator and no body would not be an
article. But still, I'd rather be very careful here and create an
empty body if no separator could ever be found. While \Lp would never
create such an article, it could be tomorrow that we might parse
foreign articles for whatever reason.
<<How to parse articles.lisp>>=
(defun parse-article (v)
(let ((pos (search #(13 10 13 10) v)))
(if pos
(make-article
:head (map 'string #'code-char (subseq v 0 pos))
:body (make-array (- (length v) (+ pos 4))
:element-type (array-element-type v)
:displaced-to v
:displaced-index-offset (+ pos 4)))
(make-article
:head (map 'string #'code-char v)
:body (make-array 0 :element-type (array-element-type v))))))
(defun hs-space-collapsed (hs)
(cl-ppcre:regex-replace-all (fmt "~a[ ~a]+" (crlf-string) #\tab) hs " "))
(defun hs-lines (lines) (str:split (crlf-string) lines))
(define-condition article-syntax-error (error)
((message :initarg :message :reader article-syntax-error-message))
(:report (lambda (condition stream)
(format stream "~a" (article-syntax-error-message condition)))))
(defun article-syntax-error! (fmt-str &rest args)
(error 'article-syntax-error
:message (apply #'fmt fmt-str args)))
(defun parse-header (header)
(let* ((h (str:collapse-whitespaces header))
(pos (search ":" h)))
(when (null pos)
(article-syntax-error! (fmt "missing colon in header |~a|" h)))
(when (<= (length h) (+ 2 pos))
(article-syntax-error! (fmt "empty header ~a" h)))
(multiple-value-bind (key val)
(values (subseq h 0 pos) (subseq h (+ 2 pos)))
(cons (str:downcase key) val))))
(defun parse-headers (hs)
(let ((ls (hs-lines (hs-space-collapsed hs))))
(mapcar #'(lambda (h) (parse-header h)) ls)))
(defun string-integer? (s) (ignore-errors (parse-integer s)))
@ %def parse-article parse-headers
We now write some procedures that we use when we're build the {\em
overview} of the command \verb|XOVER|. We write them here because
they're still part of parsing an article.
<<How to parse articles.lisp>>=
(defun get-header (key hs)
(let ((pair (assoc key hs :test #'string=)))
(if pair (cdr pair) "")))
(defun fetch-headers (g i)
"Loads the article, parses headers, and computes missing metadata dynamically."
(let* ((art-path (fmt "groups/~a/~a" g i))
(a-string (fetch-article g i))
(a-parsed (parse-article a-string))
(headers (parse-headers (article-head a-parsed))))
(enrich-headers headers art-path)))
(defun fetch-headers-destroy (g i)
(let* ((a-string (fetch-article g i))
(a-parsed (parse-article a-string))
(headers (parse-headers (article-head a-parsed))))
headers))
(defun enrich-headers (hs art-path)
"Dynamically computes bytes and lines to the parsed header alist."
(append hs
`(("bytes" . ,(fmt "~a" (filesize art-path)))
("lines" . ,(fmt "~a" (count-lines-at-path art-path))))))
(defun count-lines-at-path (path)
"Constant-memory---8 KiB---line counter."
(with-open-file (in path :direction :input :element-type '(unsigned-byte 8))
(let ((buf (make-array 8192 :element-type '(unsigned-byte 8)))
(lines 0))
(declare (type (simple-array (unsigned-byte 8) (8192)) buf)
(type fixnum lines)
(optimize (speed 3) (safety 1)))
(loop for n fixnum = (read-sequence buf in)
while (plusp n)
do (loop for i fixnum from 0 below n
when (= (aref buf i) 10)
do (incf lines)))
lines)))
@ %def get-header fetch-headers
The procedures [[extract-mid]] and [[lookup]] also belong belong in
this section. Do they really? It seems so.
<<How to parse articles.lisp>>=
(defun extract-mid (a)
(lookup "message-id" (parse-headers (article-head (parse-article a)))))
(defun lookup (key table)
(cdr (assoc key table :test #'string=)))
@ %def extract-mid lookup
\section{Commands}
\subsection{{\tt HELP}}
When someone asks for help, we present a table of commands.
<<Command help.lisp>>=
(defun cmd-help (r)
(labels ((menu (ls)
(loop for item in ls
collect (display-fn item)))
(display-fn (cmd-pair)
(let ((cmd (cdr cmd-pair)))
(fmt "~A ~A"
(command-verb cmd)
(command-description cmd)))))
(let ((lines (menu *commands-assoc*)))
(prepend-response-with
"What's on the menu today?"
(make-response :code 200 :multi-line 'yes
:request r
:data (str:join (crlf-string) lines))))))
@
\subsection{{\tt AUTHINFO}}\label{sec:authinfo}
The implementation of {\tt AUTHINFO}. When we connect to
\lp\ directly from a keyboard, it's a bit painful to authenticate with
two commands---{\tt AUTHINFO user} and {\tt AUTHINFO pass}. So we
also implemented the command {\tt LOGIN}---see
Section~\ref{sec:login}. To check the user's password, we use the
procedure [[pass?]] that's defined in the implementation of {\tt
PASSWD}.
<<authinfo error message>>=
Syntax error. Say ``authinfo USER /your-name/'' then ``authinfo PASS /your-pass/''.
@
<<Command authinfo.lisp>>=
(defun cmd-authinfo (r)
(let* ((args (mapcar #'str:upcase (request-args r))))
(cond
((not (= (length args) 2))
(bad-input r "No, no: I take exactly two arguments."))
(t
(multiple-value-bind (cmd arg) (apply #'values args)
(cond
((string= cmd "USER")
(setf (client-username *client*) arg)
(make-response :code 381 :request r
:data (fmt "Hey, ~a, please tell us your password." arg)))
((string= cmd "PASS")
(if (authinfo-check (client-username *client*) arg)
(progn
(log-user-in!)
(make-response
:code 281 :request r
:data (fmt "Welcome, ~a." (client-username *client*))))
(make-response :code 400 :request r :data "Sorry. Wrong password.")))
(t (make-response :code 400 :request r :data "<<authinfo error message>>"))))))))
(defun authinfo-check (username passwd)
(pass? username passwd))
(defun auth? ()
(eq 'yes (client-auth? *client*)))
(defun log-user-in! ()
(setf (client-auth? *client*) 'yes)
(let ((u (get-account (client-username *client*))))
(setf (account-seen u) (get-universal-time)))
(write-accounts!))
@ %def auth? log-user-in!
\subsection{{\tt CREATE-ACCOUNT}}
We allow authenticated members to invite their friends, which creates
a tree of people. ({\em An idea}. We could envision that each tree
trunk manages the rest of the tree underneath it. So I invite you, I
could change your password, say, or handle any problems you might
have. This decentralizes system administration, easing the support
burden.)
The name of each user must conform to the expression
<<Form of user names>>=
^[^\\s]+$
@
Same as in @<<Form of newsgroup names@>>. We'll let users create
whatever complicated user names they want. If they can type it up,
it's their problem.
<<Command create-account.lisp>>=
(defun user-name-conforms? (u)
(conforms-to? u "<<Form of user names>>"))
(defun cmd-create-account (r)
(with-auth
(with-n-args 1 r
(let* ((args (mapcar #'str:upcase (request-args r)))
(username (car args)))
(multiple-value-bind (username pass-or-error)
(new-account! username (client-username *client*))
(if (not username)
(make-response :code 400 :request r
:data (fmt "~a. Choose a new name." pass-or-error))
(progn
(notify-user-created username)
(make-response :code 200 :request r
:data (fmt "Okay, account ~a created with password ``~a''."
username pass-or-error)))))))))
@
<<Representation of accounts.lisp>>=
(defstruct account username seen last-post friends pass pass-locked pass-locked-why creation)
(defparameter *accounts* nil)
@ %def *accounts*
<<Command create-account.lisp>>=
(defun read-accounts! ()
(let ((*package* (find-package '#:loop)))
(with-open-file
(s "accounts.lisp"
:direction :input)
(setq *accounts* (read s))))
*accounts*)
(defun string->array (s)
(make-array (length s)
:element-type '(unsigned-byte 8)
:initial-contents (map 'vector #'char-code s)))
(defun string->sha256 (s)
(let ((d (ironclad:make-digest :sha256)))
(ironclad:produce-digest (ironclad:update-digest d (string->array s)))))
(defun new-account! (username invited-by)
(let* ((u (str:upcase username))
(p (random-string 6))
(a (make-account :username u
:pass (string->sha256 (str:upcase p))
:creation (get-universal-time))))
(multiple-value-bind (okay? reason) (user-name-conforms? u)
(declare (ignore reason))
(cond ((not okay?)
(values nil (fmt "username must conform to <<Form of user names>>")))
((get-account u)
(values nil (fmt "account ~a already exists" u)))
(t
(push u (account-friends (get-account invited-by)))
(push a *accounts*)
(write-accounts!)
(values (str:upcase username) p))))))
@ %def CREATE-ACCOUNT new-account!
To write [[write-accounts!]] we will need locking, no way to avoid
this given the parallel daily-nature of \Lp. Two processes in
parallel may ask for the writing of [[accounts.lisp]]. The process
that loses the race would have its modifications lost. What do we
need to do? We need locking no matter what.
<<Command create-account.lisp>>=
(defun write-accounts! ()
(with-file-lock ("accounts.lck")
(let ((name
(loop
(let* ((tmp (random-string 10))
(name (fmt "~a.tmp" tmp)))
(when (ignore-errors
(with-open-file (s name
:direction :output
:if-exists :error
:if-does-not-exist :create)
(write *accounts* :stream s)
t))
(return name))))))
(if (ignore-errors (rename-file name "accounts.lisp"))
(values t *accounts*)
(values nil (fmt "could not rename ~a to accounts.lisp" name))))))
(defun get-account (username)
(loop for u in *accounts*
do (when (string= (str:upcase username) (account-username u))
(return u))))
@ %def read-accounts! write-accounts! get-account
\subsection{{\tt UNLOCK-ACCOUNT}}
Inactive accounts are removed or locked---see Section
\ref{sec:inactive-users}. When an account is locked, any member can
unlock it.
<<Command create-account.lisp>>=
(defun cmd-unlock-account (r)
(with-auth
(with-n-args 1 r
(let* ((args (mapcar #'str:upcase (request-args r)))
(username (car args)))
(cond ((not (get-account username))
(make-response :code 400 :request r
:data (fmt "No such account ~a." username)))
((not (locked? username))
(make-response :code 400 :request r
:data (fmt "Can't unlock ~a because it's not locked." username)))
(t
(unlock-account! username)
(notify-user-unlocked username)
(make-response :code 200 :request r
:data (fmt "Okay, account ~a unlocked." username))))))))
(defun unlock-account! (username)
(let ((u (get-account username)))
(cond ((not u)
(values nil "no such account"))
((not (locked? username))
(values nil "account isn't locked"))
(t
(setf (account-pass u) (account-pass-locked u))
(setf (account-pass-locked u) nil)
(setf (account-pass-locked-why u) nil)))))
@ %def unlock-account!
\subsection{{\tt LOGIN}}\label{sec:login}
Besides {\tt AUTHINFO} in Section~\ref{sec:authinfo}, we also
implement a more convenient command for authentication when we
interact with \lp\ through a command-line interface. Instead of
having to say two commands, we can just say {\tt login user password}.
<<Command login.lisp>>=
(defun cmd-login (r)
(let* ((args (mapcar #'str:upcase (request-args r))))
(cond
((not (= (length args) 2))
(bad-input r "Usage: login your-username your-password"))
(t
(multiple-value-bind (name pass) (apply #'values args)
(cond
((pass? name pass)
(log-user-in-as! name)
(make-response :code 200 :request r
:data (fmt "Welcome, ~a." name)))
(t (make-response :code 400 :request r
:data (fmt "Wrong password.")))))))))
(defun log-user-in-as! (name)
(setf (client-username *client*) name)
(log-user-in!))
@
\subsection{{\tt PASSWD}}\label{sec:passwd}
A change of password is made with {\tt PASSWD current new}. Observe
that we are duplicating code from other command procedures. I think
there is a macro emerging here called [[with-upcase-args]]. %% TODO
<<Command passwd.lisp>>=
(defun cmd-passwd (r)
(with-auth
(let* ((args (mapcar #'str:upcase (request-args r))))
(cond
((not (= (length args) 2))
(bad-input r "Usage: passwd current-password new-password"))
(t
(multiple-value-bind (cur new) (apply #'values args)
(cond
((pass? (client-username *client*) cur)
(multiple-value-bind (okay? problem)
(change-passwd! (client-username *client*) new)
(if okay?
(make-response :code 200 :request r
:data "You got it. Password changed.")
(make-response :code 500 :request r
:data (fmt "Sorry: ~a" problem)))))
(t (make-response :code 400 :request r
:data (fmt "Sorry. Wrong password."))))))))))
(defun pass? (username pass)
(let ((u (get-account username)))
(and
u
(cond ((null (account-pass u)) nil)
((integerp (account-pass u))
(eq (sxhash pass) (account-pass u)))
((arrayp (account-pass u))
(equalp (string->sha256 pass) (account-pass u)))
(t (error "pass? expected to find INTEGERP or ARRAYP but found ~a"
(type-of (account-pass u))))))))
(defun change-passwd! (username newpass)
(let ((u (get-account username)))
(when (not u)
(error "I could not find account ~a." username))
(setf (account-pass u) (string->sha256 (str:upcase newpass)))
(write-accounts!)))
@ %def PASSWD pass? change-passwd!
\subsection{{\tt USERS}}\label{sec:users}
The tree of users and their friends is public. Anyone can know who
invited who.
<<Command users.lisp>>=
(defun cmd-list-users (r)
(with-auth
(prepend-response-with
"List of current users:"
(make-response
:code 200 :request r :multi-line 'yes
:data (str:join (crlf-string) (list-users))))))
(defun size-of-longest-username ()
(loop for u in *accounts*
maximizing (length (account-username u))))
(defun list-users ()
(mapcar
#'(lambda (row) (cadr row))
(sort
(loop for u in *accounts*
collect (list
(account-username u)
(fmt "~v@a~a, ~a, invited ~a"
(size-of-longest-username)
(account-username u)
(if (locked? (account-username u))
(fmt " (account locked: ~a)"
(account-pass-locked-why u))
"")
(if (last-time-seen (account-username u))
(fmt "last seen on ~a" (last-time-seen (account-username u)))
"never logged in")
(or (account-friends u) "nobody"))))
#'string<= :key #'(lambda (row) (car row)))))
(defun universal-to-human (s)
(format-timestring
nil
(universal-to-timestamp s)
:format +asctime-format+))
(defun last-time-seen (username)
(let ((u (get-account username)))
(if u (let ((s (account-seen u)))
(if s (universal-to-human s))))))
@ %def list-users
\subsection{{\tt LIST}}\label{sec:list}
The database of groups and articles is a UNIX directory. We just need
to discover which directories exist and produce a listing. The heavy
work here is finding the index interval of articles in the group.
\begin{crossedblock}
(I think we should already be optimizing this by merely caching the
information in a file that is read at start-up. I think we should
even cache the overview of the group.) %% TODO
\end{crossedblock}
I think we can clean up these group structures. We're using
[[values]] and [[multiple-value-bind]] and it suffices right now.
Let's only optimize the things we need to optimize right now---forget
the future for a moment.
<<Command list.lisp>>=
(defstruct group name high low)
(defun cmd-list (r)
(let* ((args (request-args r))
(keyw (and (= 1 (length args)) (car args))))
(cond
((or (null args) (member keyw '("NEWSGROUPS" "ACTIVE") :test #'string-equal))
(list-groups-response r))
((and keyw (string-equal keyw "OVERVIEW.FMT"))
(list-overview-fmt-response r))
(t (make-response :code 503 :request r
:data (fmt "Unsupported LIST variant ``~a''." (str:join " " args)))))))
(defun list-groups-response (r)
(prepend-response-with
"Get in the loop! Lots to choose from."
(make-response :code 215 :multi-line 'yes
:data (str:join (crlf-string) (build-groups-lines (build-groups-structs)))
:request r)))
(defun list-overview-fmt-response (r)
(prepend-response-with
"What to expect in XOVER? These."
(make-response :code 215 :multi-line 'yes
:data (str:join (crlf-string) (overview-fmt-lines))
:request r)))
(defun overview-fmt-lines ()
'("From:"
"Date:"
"Message-ID:"
"References:"
"Bytes:"
"Lines:"
"Xref:full"))
(defun build-groups-lines (ls)
(reverse
(mapcar
#'(lambda (g)
(fmt "~a ~a ~a y" (group-name g) (group-high g) (group-low g)))
ls)))
(defun build-groups-structs ()
(let ((ret-ls nil))
(dolist (g (list-groups) ret-ls)
(multiple-value-bind (low high len) (group-high-low g)
(declare (ignore len))
(setf ret-ls (cons (make-group :name g :high high :low low) ret-ls))))))
(defun between? (x from to)
(<= from x to))
(declaim (inline between?))
(defun filesize (path)
(sb-posix:stat-size
(sb-posix:stat path)))
(defun zero-file? (path)
(= (filesize path) 0))
(defun temporary-article? (path)
(or (zero-file? path)
(cl-ppcre:scan "\.tmp$" (namestring path))))
(defun article-ready?-old (path)
(not (temporary-article? path)))
<<Workaround for list-directories and list-files.lisp>>
(defun get-articles (g &optional from to)
(in-groups ;; It's okay for this to be slow because we only run this
;; one time in the birth of a group.
(let ((as (articles->integers (loop-list-files (truename g)))))
(sort (remove-if-not
#'(lambda (x) (between? x (or from x) (or to x)))
as)
#'<))))
(defun group-high-low-fallback (g)
(let* ((articles (get-articles g))
(sorted-ints (sort articles #'<)))
(values (or (car sorted-ints) 0)
(or (car (last sorted-ints)) 0)
(length sorted-ints))))
(defun update-group-meta-absolute! (g low high count)
"Atomically overwrites the meta file from scratch."
(let* ((meta-path (fmt "groups/~a/.meta/low-high-count" g))
(lock-path (fmt "~a.lck" meta-path))
(tmp-path (fmt "~a.tmp" meta-path)))
(ensure-directories-exist meta-path)
(with-file-lock (lock-path)
(with-open-file (out tmp-path :direction :output
:if-exists :supersede
:if-does-not-exist :create)
(format out "~a ~a ~a~%" low high count))
(rename-no-extension tmp-path meta-path))))
(defun update-group-meta-incremental! (g article-id)
"Atomically updates metadata when a new article is posted."
(let* ((meta-path (fmt "groups/~a/.meta/low-high-count" g))
(lock-path (fmt "~a.lck" meta-path))
(tmp-path (fmt "~a.tmp" meta-path)))
(ensure-directories-exist meta-path)
(with-file-lock (lock-path)
(multiple-value-bind (low high count) (read-low-high-count meta-path)
(with-open-file (out tmp-path :direction :output
:if-exists :supersede
:if-does-not-exist :create)
(format out "~a ~a ~a~%"
(if (zerop low) article-id low) ;; New Low
(max high article-id) ;; New High
(1+ count))) ;; New Count
(rename-no-extension tmp-path meta-path)))))
(defun read-low-high-count (meta-path)
"Reads (low high count), returning (0 0 0) if the file doesn't exist."
(with-open-file (in meta-path :direction :input :if-does-not-exist nil)
(if in
(values (read in nil 0)
(read in nil 0)
(read in nil 0))
(values 0 0 0))))
(defun group-high-low (g)
"Constant-time retrieval of group boundaries."
(ensure-directories-exist (fmt "groups/~a/.meta/" g))
(let ((meta-path (fmt "groups/~a/.meta/low-high-count" g)))
(if (probe-file meta-path)
(read-low-high-count meta-path)
;; Well, .meta/low-high-count doesn't exist, this is the first
;; time we're running, so let's compute the numbers for a
;; first time.
(multiple-value-bind (low high count) (group-high-low-fallback g)
(update-group-meta-absolute! g low high count)
(values low high count)))))
(defun articles->integers (ls)
(remove-if #'null
(mapcar #'(lambda (g)
(ignore-errors
(parse-integer (basename (uiop:unix-namestring g)))))
ls)))
(defun list-groups ()
(let ((groups (in-groups (loop-list-directories (truename ".")))))
(sort (mapcar #'(lambda (g) (basename (uiop:unix-namestring g))) groups)
#'string-lessp)))
(defun last-char (s) (char s (1- (length s))))
@
\begin{crossedblock}
<<Dead Command list.lisp>>=
(defstruct group name high low)
(defun cmd-list (r)
(prepend-response-with
"Get in the loop! Lots to choose from."
(make-response :code 215 :multi-line 'yes
:data (str:join (crlf-string) (build-groups-lines (build-groups-structs)))
:request r)))
@
\end{crossedblock}
In [[basename]], what we want to do is---if the path ends with a
slash, we invoke [[pathname]]. Otherwise, we invoke {\tt
file-namestring}.
<<Command list.lisp>>=
(defun basename (path)
(let ((s (str:collapse-whitespaces path)))
(if (char= #\/ (last-char s))
(car (last (pathname-directory s)))
(file-namestring s))))
@ %def get-articles group-high-low
To list directories and files, I have been using
\href{https://github.com/Shinmera/filesystem-utils/tree/master}{{\tt
filesystem-utils}} by Yukari Hafner. I found an issue with both
[[list-directories]] and [[list-files]] in a fresh install of
FreeBSD 14.2 and in a Debian 8.11 codename jessie. The issue is
that the [[#+cffi]] chunk of the source code incorrectly produced
[[NIL]]. (Dramatically, the same was not true in a FreeBSD
14.1.) The source code had an alternative chunk of code for
[[#-cffi]] and I discovered that this alternative worked on these
systems I tested. So, as a workaround, I incorporate these
procedures below using the chunk [[#-cffi]] to get \Lp\ working
on these systems.
<<Workaround for list-directories and list-files.lisp>>=
(defun loop-directory* (directory &rest args &key &allow-other-keys)
#+allegro (apply #'directory directory :directories-are-files NIL
:follow-symbolic-links NIL args)
#+(or clozure digitool) (apply #'directory directory :follow-links NIL args)
#+clisp (apply #'directory directory :circle T :if-does-not-exist :ignore args)
#+(or cmucl scl) (apply #'directory directory :follow-links NIL :truenamep NIL args)
#+lispworks (apply #'directory directory :link-transparency NIL args)
#+sbcl (apply #'directory directory :resolve-symlinks NIL args)
#-(or allegro clozure digitool clisp cmucl scl lispworks sbcl)
(apply #'directory directory args))
(defun loop-list-files (directory)
(let ((directory (pathname-utils:to-directory directory)))
(let* ((directory (pathname-utils:pathname* directory))
(entries
(ignore-errors
(loop-directory*
(merge-pathnames pathname-utils:*wild-file* directory)))))
(remove-if #'directory-p entries))))
(defun loop-list-directories (directory)
(let ((directory (pathname-utils:to-directory directory)))
(let* (#-(or abcl cormanlisp genera xcl)
(wild (merge-pathnames
#-(or abcl allegro cmucl lispworks sbcl scl xcl)
pathname-utils:*wild-directory*
#+(or abcl allegro cmucl lispworks sbcl scl xcl) "*.*"
directory))
(dirs
#+(or abcl xcl) (system:list-directory directory)
#+cormanlisp (cl::directory-subdirs directory)
#+genera (handler-case (loop for (p . k) in (fs:directory-list directory)
when (eql :directory k) collect p)
(fs:directory-not-found () nil))
#+clozure (ignore-errors (directory* wild :directories T :files NIL))
#+mcl (ignore-errors (directory* wild :directories T))
#-(or abcl xcl cormanlisp genera clozure mcl) (loop-directory* wild)))
(loop for path in dirs
when (directory-p path)
collect (pathname-utils:force-directory path)))))
@ %def loop-list-directories loop-list-files
\subsection{{\tt LIST OVERVIEW.FMT}}
This weirdly-named command is let news readers know what to expect in
the answer to \verb|XOVER| commands.
\begin{verbatim}
215 What to expect in XOVER? These.
Subject:
From:
Date:
Message-ID:
References:
Bytes:
Lines:
Xref:full
.
\end{verbatim}
Do we have support for commands with space? I doubt it. We don't.
Our idea is that everything-LIST is to be handled by [[cmd-list]].
This isn't such a bad idea, but it will make [[cmd-list]] handle
<<Command list overview.fmt.lisp>>=
(defun cmd-list-overview-fmt (r)
(prepend-response-with
"Get in the loop! Lots to choose from."
(make-response :code 215 :multi-line 'yes
:data (str:join (crlf-string) (build-groups-lines (build-groups-structs)))
:request r)))
@
\subsection{{\tt LISTGROUP}}\label{sec:listgroup}
A useful command. Clients such as {\em Sylpheed} ignore it, but {\em
tin} takes advantage of it.
<<Command listgroup.lisp>>=
(defun parse-nntp-range (range-str default-low default-high)
"Parses an NNTP range string into (values low high)."
(if (null range-str)
(values default-low default-high)
(let ((dash-pos (position #\- range-str)))
(if (not dash-pos) ;; Didn't find a dash.
(let ((n (parse-integer range-str :junk-allowed t)))
(values (or n default-low) (or n default-high)))
(let ((start-val (parse-integer (subseq range-str 0 dash-pos) :junk-allowed t))
(end-str (subseq range-str (1+ dash-pos))))
(if (string= end-str "")
;; Found an article number followed by a dash as in
;; 123-.
(values (or start-val default-low) default-high)
;; Found an article number followed by a dash and
;; another number as in 123-456.
(let ((end-val (parse-integer end-str :junk-allowed t)))
(values (or start-val default-low) (or end-val default-high)))))))))
(defun cmd-listgroup (r)
(with-auth
(let* ((args (request-args r))
(g (if args (car args) (client-group *client*)))
(range-arg (if (> (length args) 1) (cadr args) nil)))
(cond
((> (length args) 2)
(make-response :code 400 :request r :data "No, no: LISTGROUP takes at most two arguments."))
((not g)
(make-response :code 412 :request r :data "No newsgroup selected"))
(t
(with-group g r
(set-group! g)
(multiple-value-bind (group-low group-high group-len) (group-high-low g)
(multiple-value-bind (req-low req-high)
(parse-nntp-range range-arg group-low group-high)
(let* ((all-articles (get-articles g group-low group-high))
(filtered-articles (remove-if-not (lambda (x) (and (>= x req-low) (<= x req-high)))
all-articles)))
(when all-articles
(setf (client-article *client*) (car all-articles)))
(prepend-response-with (fmt "~a ~a ~a ~a article list follows" group-len group-low group-high g)
(make-response :code 211
:request r
:multi-line 'yes
:data (if filtered-articles
(str:join (crlf-string) (mapcar #'write-to-string filtered-articles))
""))))))))))))
(defun cmd-listgroup-old (r)
(with-auth
(let* ((args (request-args r))
(g (if args (car args) (client-group *client*))))
(cond
;; If no group is selected and no argument was provided...
((not g)
(make-response :code 412 :request r :data "must say GROUP first"))
;; When LISTGROUP takes at most one argument (the group name)...
((> (length args) 1)
(make-response :code 400 :request r :data "No, no: LISTGROUP takes at most one argument."))
(t
(with-group g r
(set-group! g)
(multiple-value-bind (low high len) (group-high-low g)
;; Fetch the list of article integers
(let ((articles (get-articles g low high)))
(setf (client-article *client*) low)
;; Prepend the 211 success line and format the multi-line response
(prepend-response-with (fmt "~a ~a ~a ~a article numbers follow" len low high g)
(make-response :code 211
:request r
:multi-line 'yes
:data (str:join (crlf-string)
(mapcar #'write-to-string articles))))))))))))
@
\subsection{{\tt GROUP}}\label{sec:group}
We just need to verify if the group exists and modify [[*client*]].
<<Command group.lisp>>=
(defun cmd-group (r)
(with-auth
(with-n-args 1 r
(let ((g (car (request-args r))))
(with-group g r
(set-group! g)
(multiple-value-bind (low high len) (group-high-low g)
(let ((ln (fmt "~a ~a ~a ~a" len low high g)))
(setf (client-article *client*) low)
(make-response :code 211 :request r :data ln))))))))
(defun group? (g)
(in-groups
(ignore-errors (directory-p g))))
(defun set-group! (g)
(setf (client-group *client*) g))
@ %def group?
\subsection{{\tt BODY}, {\tt HEAD}, {\tt ARTICLE} and {\tt NEXT}}
\label{sec:typical-cmds}
Here we have an illustration of the expressive power of first-class
procedures. We want to implement the commands {\tt BODY}, {\tt HEAD},
{\tt ARTICLE} and {\tt NEXT}. The ways to invoke them are (1) with no
argument, (2) with a single integer argument and (3) with a text
argument. In case (1), we use the number of the current
article---which is kept in [[*client*]]. In case (2), the NNTP client
specifies the article number. In case (3), the NNTP client specifies
the exact {\tt message-id}, which forces us to query the index---see
Section~\ref{sec:index} for the implementation of the index.
We're using the nonexistent procedure [[lookup-index]] below. We must
update that now. The argument [[n-or-mid]] is a message-id string for
sure. We can immediately return that article by reading /index/
<<Commands head, body, article.lisp>>=
(defun typical-cmd-head-body-article (r fn-by-number fn-by-mid)
(with-auth
(let ((args (request-args r)))
(cond ((null args)
(with-group-set
(funcall fn-by-number r (client-group *client*) (client-article *client*))))
((= 1 (length args))
(let* ((n-or-mid (car args)))
(cond ((string-integer? n-or-mid)
(with-group-set
(funcall fn-by-number r (client-group *client*) n-or-mid)))
(t (funcall fn-by-mid r n-or-mid)))))
(t (bad-input r "No, no: it takes at most two arguments."))))))
(defun cmd-head (r)
(typical-cmd-head-body-article r #'head-response #'head-response-by-mid))
(defun cmd-body (r)
(typical-cmd-head-body-article r #'body-response #'body-response-by-mid))
(defun cmd-article (r)
(typical-cmd-head-body-article r #'article-response #'article-response-by-mid))
(defun article-response (r g i)
(typical-cmd-response 220 r g i :article))
(defun head-response (r g i)
(typical-cmd-response 221 r g i :head))
(defun body-response (r g i)
(typical-cmd-response 222 r g i :body))
(defun article-response-by-mid (r mid)
(typical-cmd-response-by-mid 220 r mid :article))
(defun head-response-by-mid (r mid)
(typical-cmd-response-by-mid 221 r mid :head))
(defun body-response-by-mid (r mid)
(typical-cmd-response-by-mid 222 r mid :body))
(defun typical-cmd-response-at-path (code r path error-label response-number requested-part
&optional (not-found-code 400))
(handler-case
(let* ((headers-raw (read-headers-raw path)))
(if (null headers-raw)
(make-response :code 400 :request r :data (fmt "article ~a does not exist" error-label))
(let* ((a (parse-article headers-raw))
(mid (extract-mid headers-raw))
(head-length (length headers-raw))
(body-start (+ head-length 4)) ;; 4 bytes due to \r\n\r\n
(payload
(ecase requested-part
(:head (article-head a))
(:body (make-file-stream-payload :path path :start-pos body-start))
(:article (list (article-head a)
(crlf) (crlf)
(make-file-stream-payload :path path
:start-pos body-start))))))
(prepend-response-with (fmt "~a ~a" response-number mid)
(make-response :multi-line 'yes :code code
:request r :data payload)))))
(file-error (c)
(declare (ignore c))
(make-response :code not-found-code :request r
:data (fmt "Sorry, no such article ~a." error-label)))
(sb-posix:syscall-error (c)
(let ((msg (fmt "article ~a: ~a" error-label c)))
(stderr msg)
(make-response :code 400 :request r :data msg)))
(error (c)
(let ((msg (fmt "sorry ~a: ~a" error-label c)))
(stderr msg)
(make-response :code 400 :request r :data msg)))))
(defun typical-cmd-response (code r g i requested-part)
(typical-cmd-response-at-path
code r
(fmt "groups/~a/~a" g i)
(fmt "~a/~a" g i) i requested-part 423))
(defun typical-cmd-response-by-mid (code r mid requested-part)
(typical-cmd-response-at-path
code r
(index-path (index-hash mid))
mid
0 requested-part 400))
@
\begin{crossedblock}
<<Dead.lisp>>=
;; dead @ d17.M08.y2026.h16-0300.m36.s56
;; --8<-------------------------------------------------------->8---
;; old stuff below
;; --8<-------------------------------------------------------->8---
(defun typical-cmd-head-body-article-old (r fn-name)
(with-auth
(with-group-set
(let ((args (request-args r)))
(cond ((null args)
(funcall fn-name r (client-group *client*) (client-article *client*)))
((= 1 (length args))
(let* ((n-or-mid (car args)))
(cond ((string-integer? n-or-mid)
(funcall fn-name r (client-group *client*) n-or-mid))
(t (multiple-value-bind (group n-str) (lookup-index n-or-mid)
(if (and group n-str)
(funcall fn-name r group n-str)
(bad-input r (fmt "Unknown article ~a." n-or-mid))))))))
(t (bad-input r "No, no: it takes at most two arguments.")))))))
(defun cmd-head-old (r)
(typical-cmd-head-body-article r #'head-response))
(defun cmd-body-old (r)
(typical-cmd-head-body-article r #'body-response))
(defun cmd-article-old (r)
(typical-cmd-head-body-article r #'article-response))
(defun article-response-old (r g i)
(typical-cmd-response 220 r g i :article))
(defun head-response-old (r g i)
(typical-cmd-response 221 r g i :head))
(defun body-response-old (r g i)
(typical-cmd-response 222 r g i :body))
@
\end{crossedblock}
\begin{crossedblock}
In processing such commands, we need to verify the existence of files
{\em et cetera}. The procedure [[fetch-article]] returns [[nil]] when
the article requested doesn't exist and it throws
[[sb-posix:syscall-error]] due to [[sb-posix:stat-size]], which we
need to find the size of the article. We need to know the file size
not only to allocate an array at the right size, but also because we
must provide the size when producing the \verb|OVERVIEW|. If a
problem such as [[sb-posix:syscall-error]] appears, we just inform the
client and terminate the request---nothing else to do.
\end{crossedblock}
Our error-checking strategy below is the following. If the user
requests an article we don't have, we figure it out with
[[fetch-article]]. If a system error come up such as a failed system
call, we report it to the user and log it---there's probably nothing
else we can do. The same is the case for all other errors. What I
want to do is to log it. What's important is that we seem to have
enough code to treat any future case we might want to add and we're
not ignoring any errors at all.
\begin{crossedblock}
<<Dead Commands head, body, article.lisp>>=
(defun typical-cmd-response (code r g i requested-part)
(handler-case
(let* ((path (fmt "groups/~a/~a" g i))
(headers-raw (read-headers-raw path)))
(if (null headers-raw)
(make-response :code 400 :request r :data (fmt "article ~a/~a does not exist" g i))
(let* ((a (parse-article headers-raw))
(mid (extract-mid headers-raw))
(head-length (length headers-raw))
(body-start (+ head-length 4)) ;; 4 bytes due to \r\n\r\n
(payload
(ecase requested-part
(:head (article-head a))
(:body (make-file-stream-payload :path path :start-pos body-start))
(:article (list (article-head a)
(crlf) (crlf)
(make-file-stream-payload :path path
:start-pos body-start))))))
(prepend-response-with (fmt "~a ~a" i mid)
(make-response :multi-line 'yes :code code
:request r :data payload)))))
(sb-posix:syscall-error (c)
(let ((msg (fmt "article ~a/~a: ~a" g i c)))
(stderr msg)
(make-response :code 400 :request r :data msg)))
(error (c)
(let ((msg (fmt "unexpected condition when reading article ~a/~a: ~a" g i c)))
(stderr msg)
(make-response :code 400 :request r :data msg)))))
@ %def typical-cmd-response
\end{crossedblock}
The command \verb|NEXT| has a slight different semantics.
<<Commands head, body, article.lisp>>=
(defun cmd-next (r)
(with-auth
(let ((g (client-group *client*))
(n-cur (client-article *client*)))
(cond
((not g) (bad-input :code 412 r "must say GROUP first"))
(t (multiple-value-bind (low high len) (group-high-low g)
(declare (ignore low len))
(cond ((= n-cur high) (bad-input r "you are at the last article already"))
(t (article-next! r g)))))))))
(defun article-next! (r g)
(setf (client-article *client*) (1+ (client-article *client*)))
(let ((cur (client-article *client*)))
(make-response :code 223
:request r
:data (fmt "~a ~a" cur (mid-by-name g cur)))))
(defun mid-by-name (g name)
(extract-mid (fetch-article g name)))
@
\subsection{{\tt XOVER}}\label{sec:xover}
The procedure [[cmd-xover]] is used to figure out what the user said.
Once we have that figured out, we invoke [[xover]], which finishes the
work. Notice that when the argument [[to]] from [[xover]] is [[NIL]],
then the user is asking for articles indexed from the integer [[fr]]
to the last one.
<<Command xover.lisp>>=
(defun cmd-xover (r)
(with-auth
(with-group-set
(let ((args (request-args r)))
(cond ((null args)
(xover r (client-article *client*) (client-article *client*)))
((= 1 (length args))
(multiple-value-bind (s v)
(cl-ppcre:scan-to-strings "([0-9]+)([-]?)([0-9]*)" (car args))
(cond
((not s) (make-response :code 502 :request r :data "bad syntax"))
(t (let ((fr (parse-integer (aref v 0)))
(hifen (aref v 1))
(to (ignore-errors (parse-integer (aref v 2)))))
(when (not (string= hifen "-"))
(setq to fr))
(xover r fr to))))))
(t (make-response :code 502 :request r :data "bad syntax")))))))
(defun xover (r from to)
(assert (client-group *client*))
(let* ((g (client-group *client*))
(ls (get-articles g from to)))
(cond ((= 0 (length ls))
(make-response :code 420 :request r :data "no articles in the range"))
(t
(prepend-response-with
"Okay, your overview follows..."
(make-response
:code 224 :request r :multi-line 'yes
:data (str:join
(crlf-string)
(loop for i in ls
collect (xover-format-line
i
(remove-if-not
#'(lambda (h)
(member (car h) (xover-headers)
:test #'string=))
(fetch-headers g i)))))))))))
(defun xover-format-line-new (i hs)
(str:concat (fmt "~a~a" i #\tab)
(str:join #\tab (mapcar #'(lambda (h) (or (get-header h hs) ""))
(xover-headers)))))
(defun xover-format-line (i hs)
(str:concat (fmt "~a~a" i #\tab)
(str:join #\tab
(mapcar #'(lambda (h) (get-header h hs))
(xover-headers)))))
(defun xover-headers ()
'("subject" "from" "date" "message-id" "references" "bytes" "lines"))
@
\subsection{{\tt XHDR}}
The {\tt XHDR} command is defined by RFC 2980 section 2.6. The
purpose of this command is to let clients quickly grab specific
information they're looking for. Suppose a client is trying to build
the thread of a certain message. It wants to grab all articles whose
message-id is listed by the \verb|references| header of the article.
Then it says {\tt XHDR references <some.message.id>}. It gets an
answer such as
%
\begin{verbatim}
xhdr references <some.message.id>
221 Header information for references follows (from the article)
<another.message.id> <yet.another.message.id> <a.third.one>
.
\end{verbatim}
%
The client can now issue a {\tt HEAD} for each of these ones.
<<Command xhdr.lisp>>=
(defun cmd-xhdr (r)
(with-auth
(with-group-set
(let ((args (request-args r)))
(cond
((or (null args) (> (length args) 2))
(make-response :code 502 :request r
:data "bad syntax: usage is XHDR header [range|message-id]"))
(t
(let ((header (string-downcase (car args)))
(range-arg (cadr args)))
(cond
((null range-arg)
(xhdr r header (client-article *client*) (client-article *client*)))
((message-id-syntax? range-arg)
(xhdr-by-message-id r header range-arg))
(t
(multiple-value-bind (fr to) (parse-range range-arg)
(if (not fr)
(make-response :code 502 :request r :data "bad syntax")
(xhdr r header fr to))))))))))))
(defun message-id-syntax? (s)
(and (> (length s) 0) (char= (char s 0) #\<)))
(defun parse-range (s)
"Parses S of the form N, N-, or N-M. Returns (values from to), or
(values nil nil) when S doesn't conform."
(multiple-value-bind (matched v) (cl-ppcre:scan-to-strings "([0-9]+)([-]?)([0-9]*)" s)
(if (not matched)
(values nil nil)
(let ((fr (parse-integer (aref v 0)))
(hifen (aref v 1))
(to (ignore-errors (parse-integer (aref v 2)))))
(values fr (if (string= hifen "-") to fr))))))
(defun xhdr (r header from to)
(assert (client-group *client*))
(let* ((g (client-group *client*))
(ls (get-articles g from to)))
(cond ((= 0 (length ls))
(make-response :code 420 :request r :data "no articles in the range"))
(t
(prepend-response-with
(fmt "~a header follows" header)
(make-response
:code 221 :request r :multi-line 'yes
:data (str:join
(crlf-string)
(loop for i in ls
collect (xhdr-format-line i (get-header header (fetch-headers g i)))))))))))
(defun xhdr-by-message-id (r header mid)
(multiple-value-bind (g n) (lookup-by-message-id mid)
(if (not (and g n))
(make-response :code 430 :request r :data "no such article")
(handler-case
(prepend-response-with
(fmt "~a header follows" header)
(make-response :code 221 :request r :multi-line 'yes
:data (xhdr-format-line 0 (get-header header (fetch-headers g n)))))
(error (c)
(declare (ignore c))
(make-response :code 430 :request r :data "no such article"))))))
(defun xhdr-format-line (i value)
(fmt "~a ~a" i value))
@ %def cmd-xhdr
\subsection{{\tt MODE READER}}\label{sec:mode-reader}
So, we're always in reader mode, so we just ignore this command.
<<Command mode reader.lisp>>=
(defun cmd-mode (r) ;; Whatever.
(make-response :code 200 :request r :data "Sure thing."))
@ %def
\subsection{{\tt DATE}}\label{sec:date}
It's always useful to know the time and date at a computer.
\begin{crossedblock}
We should surely format it a bit better than what {\tt now} does.
\end{crossedblock}
<<Command date.lisp>>=
(defun nntp-date-header ()
"An RFC 1123 compliant date for use in article headers."
(format-timestring nil (now) :format +rfc-1123-format+ :timezone +utc-zone+))
(defun nntp-date-command ()
"Generates the yyyymmddhhmmss UTC string for the NNTP DATE command."
(format-timestring nil (now)
:format '(:year (:month 2) (:day 2) (:hour 2) (:min 2) (:sec 2))
:timezone +utc-zone+))
(defun cmd-date (r)
(make-response :code 201
:request r
:data
(nntp-date-command)))
@ %def nntp-date-header
\subsection{{\tt QUIT}}\label{sec:quit}
The use of {\tt QUIT} has a conection to [[main-loop]]: when the user
says {\tt QUIT}, [[main-loop]] must terminate.
<<Command quit.lisp>>=
(defun cmd-quit (r)
(make-response :code 205 :data "Good-bye." :request r))
@ %def
\subsection{{\tt DD}}\label{sec:dd}
The command {\tt DD} means ``\underline{d}isplay client
\underline{d}ata structures''. It shows to the client the internal
state of how the server sees it.
<<Command dd.lisp>>=
(defun cmd-dd (r)
(make-response :code 200 :data (fmt "state: ~a" *client*) :request r))
@ %def
\subsection{{\tt POST}}\label{sec:post}
If the client says {\tt POST}, then we continue to read line after
line until we find \verb|.\r\n|. Having done that, we must check
whether we have a conformant article at hand. The definition of
conformant is given by [[conforms?]]: the article must have the
headers required by [[headers-required-from-clients]].
<<Command post.lisp>>=
<<Does an article conform?.lisp>>
(defun suggest-message-id (&optional (n 20))
(fmt "<~a@loop>" (random-string n)))
(defun random-string (size)
(let* ((universe "abcdefghijklmnopqrstuvwxyz")
(len (length universe))
(state (make-random-state t))
mid)
(dotimes (c size)
(setq mid (cons (char universe (random len state)) mid)))
(coerce mid 'string)))
@
Now it's time to look at the header \verb|newsgroups|. The name of
each group must conform to the expression
<<Form of newsgroup names>>=
^[^\\s/]+$
@
In other words, let group names go wild. They cannot contain a slash
or a space of any kind anywhere on the name---more literally: they
must begin with any character that's not a space and must have at
least one character. The problem wish slashes is that each group will
be a directory on a UNIX file system, so we cannot let slashes appear.
People should have total freedom in naming groups. If users create
groups that mess up the local organization, then people should discuss
the matter and find a solution. Let's let people mess it up instead
of trying to stop them.
<<Command post.lisp>>=
(defun cmd-post (r)
(with-auth
(send-response!
(make-response :code 340
:data (fmt "Okay, go ahead. Suggested message-id ~a." (suggest-message-id))))
(let ((tmp (fmt "tmp/post-~a.tmp" (random-string 12))))
(unwind-protect
(handler-case
(progn
(nntp-read-article-to-disk tmp)
(stderr "finished writing article to disk in ~a~%" tmp)
(let* ((headers-raw (read-headers-raw tmp))
(headers-str (bytes->string headers-raw))
(hds (parse-headers headers-str))
(mid (get-header "message-id" hds))
(ngs (newsgroups-header->list (get-header "newsgroups" hds))))
(stderr "finished reading the headers of the tmp file~%")
(stderr "headers string: ~a~%" headers-str)
(conforms-headers? headers-str) ;; raises a condition if it doesn't go well
(let* ((hash (store-article-in-index! tmp mid)))
(stderr "stored ~a from ~a~%" hash mid)
(dolist (ng ngs)
(let ((new-id (link-article-into-group-insist! hash ng (get-next-article-id ng))))
(update-group-meta-incremental! ng new-id)))
(stderr "linking finished~%")
(update-last-post-date! (client-username *client*))
(make-response :code 240 :request r :data "Thank you! Your article has been saved."))))
(article-syntax-error (c)
(make-response
:code 400 :request r
:data (fmt "Sorry. Your article doesn't conform: ~a." c)))
(already-seen-article (c)
(make-response :code 441 :request r :data (fmt "~a" c))))
(ignore-errors (delete-file tmp))))))
@
<<Command post.lisp>>=
(defun newsgroups-header->list (s)
(mapcar #'(lambda (n) (str:trim (string-downcase n))) (str:split "," s)))
@ %def post
<<Command post.lisp>>=
(defun update-last-post-date! (username)
(let ((u (get-account username)))
(setf (account-last-post u) (get-universal-time))))
@ %def update-last-post-date!
\begin{crossedblock}
The job of [[save-article-try]] is to atomically allocate an article
name in a group. The atomicity is achieved with [[:if-exists]] in the
[[with-open-file]] macro. When [[if-exists]] is {\tt nil}, the {\tt open}
system call uses the flag \verb|O_EXCL|, giving us an atomic operation.
So the first [[with-open-file]] allocates the name. If successful, we
copy the already-streamed article from [[src-path]] into a temporary
file next to it and atomically rename it into place.
\end{crossedblock}
<<Command post.lisp>>=
(defun rename-no-extension (old new)
(rename-file (merge-pathnames old (uiop:getcwd))
(merge-pathnames (make-pathname :name new :type :unspecific) (uiop:getcwd))))
@
\begin{crossedblock}
<<Dead Command post.lisp>>=
(defun save-article-try-old (g name-try tmp-path)
(stderr "going to try to save ~a with name ~a/~a~%" tmp-path g name-try)
(let ((name (fmt "~a" name-try))
(tmp (fmt "~a.tmp" name-try)))
(with-open-file
(s name
:direction :output
:if-exists nil ; atomic O_EXCL allocation
:if-does-not-exist :create)
(when (null s)
(stderr "warning: save-article-try: ~a exists~%" name)
(return-from save-article-try-old 'name-exists)))
(stderr "going to rename in save-article-try~%")
;; We've been called to save tmp-path to its permanent name. We're
;; merely going to rename it there. So the rename call is now
;; tmp/post-tmpfile.tmp to index/bb/bb/hash. To get the hash we
;; need need the message-id.
(stderr "current-directory: ~a~%" (uiop:getcwd))
(stderr "default-pathname: ~a~%" *default-pathname-defaults*)
;(stderr "rename-no-extension ~a ~a~%" (fmt "~a" tmp-path) (fmt "~a" name))
;; The call to rename-no-extension must be at the root, so I can't
;; localize my life using in-group or in-groups here. Leaving it
;; like that.
;;(rename-no-extension (fmt "~a" tmp-path) (fmt "groups/~a/~a" g name))
;; We don't call rename here any longer. The article is now
;; safely written to tmp and it's time to store it at its
;; permanent path, which is computed by store-article-in-index!
;; So go ahead and do that. But we need the MID now! Delegated
;; it to the index itself. (Notice we don't need G here anymore.)
(store-article-in-index! tmp-path)))
@
The procedure [[save-article-insist]] insists on calling
[[save-article-try]] until it finds an article name that has not been
allocated. The argument [[name]] is an integer, incremented at each
iteration (and it's the loop for $x$ from $x$ that makes the
increments).
<<Command post.lisp>>=
(defun save-article-insist-old (g name src-path)
(loop for name from name do
(when (not (eql 'name-exists (save-article-try-old g name src-path)))
(return (values name t)))))
@
\end{crossedblock}
<<Command post.lisp>>=
(defun get-next-article-id (g)
(multiple-value-bind (low high len) (group-high-low g)
(declare (ignore low len))
(1+ high)))
@ %def get-next-article-id
{\bf How to read lines in the NNTP protocol?} ...
<<Command post.lisp>>=
(defun nntp-read-article-to-disk (tmp-path)
"Streams an article to disk."
(ensure-directories-exist "tmp/")
(with-open-file (out tmp-path
:direction :output
:element-type '(unsigned-byte 8)
:if-exists :error)
(loop
(let ((line (nntp-read-line)))
(when (end-of-article? line)
(return tmp-path))
(let ((start-idx (if (and (> (length line) 0) (= (aref line 0) 46)) 1 0)))
(write-sequence line out :start start-idx)))
(write-byte 13 out)
(write-byte 10 out))))
(defun end-of-article? (ls)
;; A line is the NNTP terminator only if it's exactly the single byte
;; 46 (#\.). LENGTH/ELT instead of EQUAL-against-a-list, since
;; NNTP-READ-LINE hands back a vector.
(and ls (not (eq ls :eof)) (= (length ls) 1) (= (elt ls 0) 46)))
@ %def nntp-read-line-buffered nntp-read-article-to-disk
Now let's move to the complicated side of life. This is the very
heart of \Lp. Our data structure of interest here is a buffer with two
pointers into it, {\tt head} and {\tt tail}. The head just points to
a place in the buffer where data yet to be consumed begins and {\tt
tail} points to where it ends. All data coming through the network
(or coming locally from someone's keyboard on standard input) is
stored in this buffer.
<<Global variable to hold the connections spoken lines.lisp>>=
(defstruct nntp-stream-buffer
(data (make-array 8192 :element-type '(unsigned-byte 8)))
(head 0 :type fixnum)
(tail 0 :type fixnum))
(defparameter *network-buffer* (make-nntp-stream-buffer))
(defun nntp-read-line (&optional (s *standard-input*))
(nntp-read-line-buffered s *network-buffer*))
@ %def *network-buffer*
Why do we need a fast procedure here? Because I/O is the slowest thing
in computers. For instance, if we allow attachments in posts (which
we don't), the performance penalty is clearly noticeable.
There is only one line-reading path. Bytes always land in
[[*network-buffer*]]; [[find-lf]] and [[extract-line]] do the framing
work; the sole branch is inside [[fetch-more-bytes]], which prefers a
raw POSIX {\tt read(2)} and falls back to a [[read-byte]] loop only
when the stream has no underlying file descriptor (Gray streams under
SLIME, string streams in tests, and the like). Terminal sessions and
{\tt tcpserver} sockets both take the fast path.
The NNTP protocol establishes that line termination is done with
\verb|\r\n|, but we also accept a bare \verb|\n| because we talk to the
server from the command line with tools that do not always send
CRLF. [[extract-line]] strips a preceding CR when it is present, so
both terminators produce the same clean line of bytes.
How to read the procedure [[nntp-read-line-buffered]]? The procedure
is an entire small program with a library of helpers. The main
program sits at the bottom. We begin by looking for a linefeed in the
buffer. If there is one, an entire line is ready to be extracted. If
there isn't, the buffer is either empty or holds only a partial line;
in either case we refill.
What does refilling do? First it checks that we still have room---a
pathological line that never ends must not grow the buffer forever; we
signal an error and let [[main-loop]] decide what to do. Next, any
bytes that already form a partial line are slid to the front of the
buffer with [[replace]] (a memmove). Then [[fetch-more-bytes]] obtains
more data. Finally we search again for a linefeed and either extract
the completed line or recurse to refill once more.
A partial line left in the buffer after an EOF is returned to the
caller; the caller should treat it as a broken client and close the
connection. We deliver everything we have, even when the peer has
already gone away.
The only asymmetry that remains is how bytes arrive. [[%unix-read]]
peels the stream with [[fd-stream-of]] until it finds an
{\tt sb-sys:fd-stream}, then issues a single POSIX {\tt read(2)}.
That path is taken for ordinary terminals and for sockets handed to us
by {\tt tcpserver}. When the stream is a Gray stream (no file
descriptor anywhere in its wrapper chain), [[fd-stream-of]] signals a
{\tt type-error}; [[fetch-more-bytes]] catches it and falls back to
[[%portable-read]], a [[read-byte]] loop that blocks for the first
byte and then slurps whatever is immediately available. The contract
is identical: return as soon as at least one byte is ready. The
fallback costs nothing on the path we care about---human typing or
SLIME---and keeps the framing logic completely shared.
<<Command post.lisp>>=
(defun nntp-read-line-buffered (stream buffer)
(let* ((data (nntp-stream-buffer-data buffer))
(capacity (length data)))
(labels ((find-lf (start end)
(position 10 data :start start :end end))
(extract-line (lf-pos)
(let* ((start (nntp-stream-buffer-head buffer))
;; If the previous character is CR (13), strip it
(end-line (if (and (> lf-pos start) (= (aref data (1- lf-pos)) 13))
(1- lf-pos)
lf-pos))
(line (subseq data start end-line)))
(setf (nntp-stream-buffer-head buffer) (1+ lf-pos))
line))
(refill-and-extract-line ()
(let* ((head (nntp-stream-buffer-head buffer))
(tail (nntp-stream-buffer-tail buffer))
(remaining (- tail head)))
;; 1. Prevent buffer saturation/overflow
(when (= remaining capacity)
(stderr "line too long in the network buffer: [~A]" (subseq data head tail))
(error "no space left on the network buffer for the current line"))
;; 2. Shift remaining bytes to the start (fast memmove)
(when (> remaining 0)
(replace data data :start1 0 :start2 head :end2 tail))
(setf (nntp-stream-buffer-head buffer) 0)
(setf (nntp-stream-buffer-tail buffer) remaining)
;; 3. Fetch data via the unified dispatch mechanism
(let* ((n (fetch-more-bytes stream data remaining (- capacity remaining)))
(new-tail (+ remaining n)))
(setf (nntp-stream-buffer-tail buffer) new-tail)
(let ((lf-pos (find-lf remaining new-tail)))
(if lf-pos
(extract-line lf-pos)
(refill-and-extract-line)))))))
;; --- Main flow ---
(let ((lf-pos (find-lf (nntp-stream-buffer-head buffer) (nntp-stream-buffer-tail buffer))))
(if lf-pos
(extract-line lf-pos)
(refill-and-extract-line))))))
(defun fetch-more-bytes (stream buf start max-count)
"Try the fast POSIX path; fall back to a portable read-byte loop
when the stream has no underlying fd (Gray streams under SLIME,
string streams in tests, etc.)."
(handler-case (%unix-read stream buf start max-count)
(type-error ()
(%portable-read stream buf start max-count))))
(defun %portable-read (stream buf start max-count)
;; Blocks for the VERY FIRST byte to respect the wait-for-data contract,
;; preventing busy-waiting loops.
(let ((first-byte (read-byte stream nil :eof)))
(when (eq first-byte :eof)
(error 'end-of-file :stream stream))
(setf (aref buf start) first-byte)
;; Slurp any IMMEDIATELY available bytes to minimize looping overhead,
;; up to max-count. 'listen' returns T if a byte is ready on the wire.
(let ((count 1))
(loop while (and (< count max-count) (listen stream))
do (let ((b (read-byte stream nil :eof)))
(when (eq b :eof) (loop-finish))
(setf (aref buf (+ start count)) b)
(incf count)))
count)))
(defun %unix-read (stream buf start max-count)
;;; One POSIX read(2) on STREAM's underlying fd.
;;;
;;; Blocks until at least one byte arrives, then returns immediately with
;;; however many bytes the kernel has buffered (up to MAX-COUNT).
;;; Retries transparently on EINTR (signals can interrupt system calls).
;;; Signals END-OF-FILE when the peer closes the connection.
(let ((fd (sb-sys:fd-stream-fd (fd-stream-of stream))))
(sb-sys:with-pinned-objects (buf)
(loop
(multiple-value-bind (n err)
(sb-unix:unix-read fd
(sb-sys:sap+ (sb-sys:vector-sap buf) start)
max-count)
(cond
((and (null n) (= err sb-unix:eintr)))
((or (null n) (zerop n))
(error 'end-of-file :stream stream))
(t (return n))))))))
(defun fd-stream-of (stream)
"Peel away SYNONYM-STREAM and TWO-WAY-STREAM wrappers until we reach
the underlying FD-STREAM. Signals a clear error if no FD-STREAM is found."
(etypecase stream
(sb-sys:fd-stream stream)
(synonym-stream (fd-stream-of (symbol-value (synonym-stream-symbol stream))))
(two-way-stream (fd-stream-of (two-way-stream-input-stream stream)))))
@ %def nntp-read-line-buffered
<<Command post.lisp>>=
(defun list->bytes (ls)
(mapcar #'data->bytes ls))
(defun vector->bytes (v)
(mapcar #'data->bytes (coerce v 'list)))
(defun data->bytes (d)
(etypecase d
(null nil)
(integer (list d))
(string (string->bytes d))
(cons (list->bytes d))
(vector (vector->bytes d))))
(defun add-crlf-between (ls-of-ls)
;; Add \r\n to each ``line''. Returns List-of Byte.
(mapcar #'(lambda (ls) (append ls (list 13 10))) ls-of-ls))
(defun string->bytes (s)
(map 'list #'char-code s))
(defun bytes->string (ls)
(map 'string #'code-char ls))
@
{\bf Does the article conform?} RFC 5536 obliges every article to
have exactly \verb|date|, \verb|from|, \verb|message-id|,
\verb|newsgroups|, \verb|path| and \verb|subject| headers. The
headers \verb|path| is \Lp's responsibility, but it's used only in a
network of servers---so we're leaving that out for now.
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 publish news to be received at the same time by various
groups; we would make such plans all go down the drain. So 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 the article is susceptible to be saved.
\begin{crossedblock}
So the message here is that if an article is vetted by [[conforms?]],
then it can be saved. Any problem with the article must be reported
by [[conforms?]].
<<Dead Does and article conform?.lisp>>=
(defun conforms?-old (bs)
(conforms-headers? (article-head (parse-article bs))))
@
\end{crossedblock}
<<Does an article conform?.lisp>>=
(defun conforms-headers? (headers-str)
"HEADERS-STR is the raw header block (without the body).
Returns (values T NIL) on success, or (values NIL error-string)."
(let* ((headers (parse-headers headers-str))
(missing (loop for h in (headers-required-from-clients)
unless (lookup h headers)
collect h)))
(cond
(missing (article-syntax-error!
(fmt "missing the ~a ~a"
(str:join ", " (mapcar (lambda (h) (fmt "/~a/" h)) missing))
(word-plural (length missing) "header"))))
(t
(let ((ngs (newsgroups-header->list (get-header "newsgroups" headers)))
(ngs-dont-exist nil))
(dolist (g ngs)
(when (or (not (group-name-conforms? g))
(not (group? g)))
(push g ngs-dont-exist)))
(if (not (zerop (length ngs-dont-exist)))
(article-syntax-error! (fmt "the ~a ~a just ~a exist"
(word-plural (length ngs-dont-exist) "newsgroup")
(str:join ", " (sort ngs-dont-exist #'string<))
(word-plural (length ngs-dont-exist) "doesn't")))
(values t nil)))))))
(defun text/plain? (header-s)
;; I say T when S begins with "text/plain" or when S is "".
(let* ((s (str:collapse-whitespaces header-s))
(needle "text/plain")
(len (min (length needle) (length s))))
(or (zerop len)
(and (<= (length needle) (length s))
(string= needle s :end1 len :end2 len)))))
(defun headers-required-from-clients ()
'("from" "newsgroups" "subject" "message-id" "date"))
@
\begin{crossedblock}
Notice that to simplify matters we're duplicating articles
cross-posted. What we should do is write the article to the first
group in the list of \verb|newsgroups| and then make a symbolic link
to all others. Why are we saying this here? This should be said in
the [[post]] procedure. You know what? Let's commit what we have
right now and let's tackle the index. We gotta push on through. (But
while I'm gone I meant it---everything is gonna be alright.)
\end{crossedblock}
\subsection{{\tt CREATE-GROUP}}
We allow every user to create their own groups. (Are we crazy?) When
someone creates a group, we post an article to {\tt
local.control.news} notifying everyone that a new group has been
created. People then have a chance to subscribe to the new group. We
assume that when someone creates a group, it's either no problem at
all or it has been discussed with the community beforehand.
<<Command create-group.lisp>>=
(defun cmd-create-group (r)
(with-n-args 1 r
(let ((g (string-downcase (car (request-args r)))))
(multiple-value-bind (okay? reason)
(group-name-conforms? g)
(if (not okay?)
(make-response :code 580 :request r
:data (fmt "group name does not conform: ~a" reason))
(progn
(multiple-value-bind (path created?)
(in-groups (ensure-directories-exist (concatenate 'string g "/")))
(declare (ignore created?))
(if (not path)
(make-response :code 581 :request r
:data (fmt "could not create group ~a"
(if (group? g)
"because it already exists"
"but we don't know why---sorry!")))
(progn
(notify-group-created g)
(make-response :code 280 :request r
:data (fmt "group ~a created" g)))))))))))
(defun group-name-conforms? (g)
(conforms-to? g "<<Form of newsgroup names>>"))
@ %def CREATE-GROUP group-name-conforms?
\subsection{{\tt REPL}}
\lp\ is {\em totally} hackable. Users can say {\tt repl} to have
complete control over their \lxxp\ process.
<<Command repl.lisp>>=
(defun cmd-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.lisp>>=
(defparameter *enable-nntp-repl* t)
@
\subsection{{\tt CAPABILITIES}}
<<Command capabilities.lisp>>=
(defun cmd-capabilities (r)
(prepend-response-with
"We are very capable! Please, take note:"
(make-response
:code 101 :multi-line 'yes :request r
:data (str:join (crlf-string) (capabilities-lines)))))
(defun capabilities-lines ()
(append
(list "VERSION 2"
"READER")
(when (auth?) (list "POST"))
(list "AUTHINFO USER"
"LIST ACTIVE NEWSGROUPS OVERVIEW.FMT"
(fmt "IMPLEMENTATION LOOP ~a" *git-hash*))))
@
\subsection{{\tt SEARCH}}
Oh, yes, we've implemented a \verb|SEARCH| command. We want to
encourage users to reference articles by their message-ids so that
people can cross-reference discussions that might be very old.
First thing to keep in mind here is that we're now having to decide in
which encoding we will interpret articles. We'll apply the following
trick. We'll continue to consider articles are mere byte sequences,
but just so we can use string functions for a more reasonable source
code, we choose the LATIN encoding because it perfectly maps to the
0--255 byte range. In other words, ISO-8859-1 is an encoding that's
really no encoding at all---it's more suitable to the task than 7-bit
ASCII.
<<Command search.lisp>>=
(defun all-groups ()
"Reads the groups/ directory producing a list of all group names."
(let ((groups (directory "groups/*/")))
(mapcar (lambda (path)
(str:trim (first (last (pathname-directory path)))))
groups)))
(defun group-article-path (group article-id)
"Returns the relative filesystem path string for an article in a group."
(fmt "groups/~a/~a" group article-id))
(defun get-header-from-file (filepath target-header)
"Extracts TARGET-HEADER from FILEPATH using LOOP's native parsing pipeline."
(if (probe-file filepath)
(ignore-errors
(let* ((headers-raw (read-headers-raw filepath))
(headers-str (bytes->string headers-raw))
(hds (parse-headers headers-str))
(val (get-header (string-downcase target-header) hds)))
(if (string= val "") "(none)" val)))
"(none)"))
(defun cmd-search (r)
"Executes the SEARCH command, producing at most 10 positive matches.
The first argument must be a single group name. That's the limitation
we impose right now."
(with-auth
(let* ((args (request-args r))
(group (car args))
(queries (cdr args)))
(when (null group)
(return-from cmd-search (make-response :code 412 :request r :data "you must specify a group")))
(when (not (group? group))
(make-response :code 412 :request r :data "no such group"))
(when (null queries)
(return-from cmd-search (make-response :code 412 :request r :data "you must provide query strings")))
(let ((match-count 0)
(results '()))
(catch 'search-done
(let ((g group))
(let ((articles (get-articles g)))
(dolist (art-num articles)
(let* ((filepath (group-article-path g art-num))
(snippet (scan-article-for-search filepath queries)))
(when snippet
(when (> match-count 0) (push "" results)) ;; a spacer between separate articles
(dolist (line (format-search-result filepath snippet))
(push line results))
(incf match-count)
(when (>= match-count 10)
(throw 'search-done t))))))))
(if (> match-count 0)
(prepend-response-with (format nil "200 found ~a matches (10 maximum)" match-count)
(make-response :code 200
:request r
:multi-line 'yes
:data (str:join (crlf-string) (nreverse results))))
(make-response :code 430 :request r :data "no articles found"))))))
(defun format-search-result (filepath snippet)
"Formats headers and the context block for a single matched article into a list of strings."
(let ((from (or (get-header-from-file filepath "from") "(none)"))
(date (or (get-header-from-file filepath "date") "(none)"))
(newsgroup (or (get-header-from-file filepath "newsgroups") "(none)"))
(msg-id (or (get-header-from-file filepath "message-id") "(none)"))
(scissors "--8<-------------------------------------------------------->8---")
(lines '()))
(push (fmt "From: ~a" from) lines)
(push (fmt "Date: ~a" date) lines)
(push (fmt "Newsgroups: ~a" newsgroup) lines)
(push (fmt "Message-ID: ~a" msg-id) lines)
(push "" lines)
(push scissors lines)
(when (first snippet) (push (first snippet) lines))
(push (second snippet) lines)
(when (third snippet) (push (third snippet) lines))
(push scissors lines)
(nreverse lines)))
(defun scan-article-for-search (filepath queries)
"Scans an article line by line. Returns a 3-line context snippet around the first
match if ALL queries are found in the article. Extremely memory efficient."
(when (probe-file filepath)
(with-open-file (stream filepath :direction :input :element-type 'character :external-format :latin-1)
(let ((prev-line nil)
(curr-line (read-line stream nil nil))
(next-line (read-line stream nil nil))
(unfound-queries (copy-list queries))
(snippet nil))
(loop while curr-line do
(let ((matched-any nil))
;; Check current line against all remaining unfound queries
(dolist (q unfound-queries)
(when (search q curr-line :test #'char-equal)
(setf matched-any t)
(setf unfound-queries (remove q unfound-queries :test #'string-equal))))
;; Capture the very first matched context block
(when (and matched-any (null snippet))
(setf snippet (list prev-line curr-line next-line))))
;; Early exit if all queries are found
(when (null unfound-queries)
(return-from scan-article-for-search snippet))
;; Shift the 3-line sliding window
(setf prev-line curr-line
curr-line next-line
next-line (read-line stream nil nil)))
;; If EOF reached, ensure ALL queries were found before returning the snippet
(if (null unfound-queries) snippet nil)))))
@
\section{Publication of news}
If you're interested in being notified about what's going on in the
\lp, then subscribe to {\tt local.control.news}. Group creation,
invitations {\em et cetera} are published there.
<<Broadcasting.lisp>>=
(defun notify-group-created (g)
(post-notification
:subject (fmt "new group ~a by ~a" g (client-username *client*))
:body (fmt "Blame ~a for the group ~a just created." (client-username *client*) g)))
(defun notify-user-created (u)
(post-notification
:subject (fmt "new account ~a by ~a" u (client-username *client*))
:body (fmt "Blame ~a for inviting ~a." (client-username *client*) u)))
(defun notify-user-unlocked (u)
(let ((guilty (client-username *client*)))
(post-notification
:subject (fmt "account ~a unlocked by ~a" u guilty)
:body (fmt "Blame ~a for unlocking ~a." guilty u))))
(defun post-notification (&key subject body)
(in-groups (ensure-directories-exist "local.control.news/"))
(let ((tmp (fmt "tmp/notify-~a.tmp" (random-string 10)))
(mid (suggest-message-id)))
(unwind-protect
(progn
;; XXX: abstract this away into its own procedure.
(with-open-file (out tmp
:direction :output
:element-type '(unsigned-byte 8)
:if-exists :supersede
:if-does-not-exist :create)
(flet ((wline (s)
(write-sequence (map 'vector #'char-code s) out)
(write-byte 13 out) (write-byte 10 out)))
(wline (fmt "From: Loop"))
(wline (fmt "Subject: ~a" subject))
(wline (fmt "Newsgroups: local.control.news"))
(wline (fmt "Message-ID: ~a" mid))
(wline (fmt "Date: ~a" (nntp-date-header)))
(write-byte 13 out) (write-byte 10 out)
(write-sequence (map 'vector #'char-code body) out)
(write-byte 13 out) (write-byte 10 out)))
(let ((headers-raw (read-headers-raw tmp)))
(post tmp headers-raw)))
(ignore-errors (delete-file tmp)))))
@ %def notify-group-created notify-user-created
\section{The database of articles}\label{sec:index}
An NNTP server needs to store articles somewhere. More appropriately
for our presentation, we can begin with the fact that such servers
must have an index of articles. Each article is indexed by its
message-id. For example, the article
%
\begin{verbatim}
From: Eva Lu <evalu@tor.soy>
Newsgroups: comp.unix
Subject: xv6: an introduction
Date: Wed, 24 Jul 2024 22:42:50 -0300
Message-ID: <87plr25js5.fsf@tor.soy>
Cancel-Lock: sha1:82E8hqL1D1WQ9xc+CfnEYbFAaJo=
MIME-Version: 1.0
Content-Type: text/plain; charset=utf-8
Content-Transfer-Encoding: 8bit
\end{verbatim}
%
is indexed by the header {\tt message-id}. If you ask for article
{\tt <87plr25js5.fsf@tor.soy>}, \Lp\ will tell you that you can find
the article in group {\tt comp.unix} and its numeric ID is integer,
say 37. Note that the number 37 is not inside the article, but only
in the name of the file stored in the file system.
How do we store our articles? In a UNIX directory in a way that we
can quickly locate it on the file system. Before storing an article,
we read its headers, so we know its message-id. From the message-id,
we compute a hash of it whose first two bytes determines the
subdirectories in which we can find the article. For example, the
article above has a hash whose first bytes as {\tt "ff9358..."}, so
you would find it at {\tt index/ff/93/ff9358...}
This means we're using a two-level hierarchy for performance reasons.
This is likely not sufficient for the binary USENET, but it's likely
pretty reasonable for the plain-text USENET. We hold the position
that the USENET should be never be nor have been used for binary file
exchange, so we don't even want to support such thing. Keep in mind
that \Lp\ is being designed for a circle of friends, but we are
definitely able to support the large community as well.
<<How to index articles.lisp>>=
<<Helper procedures for the index.lisp>>
(define-condition already-seen-article (error)
((mid :initarg :mid
:initform nil
:reader already-seen-article-mid))
(:report (lambda (condition stream)
(format stream "Message-id ~a has already been seen."
(already-seen-article-mid condition)))))
(defun store-article-in-index! (tmp-path mid)
(let* ((hash (index-hash mid))
(path-id (index-path hash)))
(ensure-index-directories! hash)
(if (not (probe-file path-id))
(rename-no-extension tmp-path path-id)
(error 'already-seen-article :mid mid))
hash))
(defun link-article-into-group-insist! (hash ng name)
(loop for c from name
do (let ((result (link-article-into-group! hash ng c)))
(unless (eq result :name-exists)
(return (values result t))))))
(defun link-article-into-group! (hash g name)
(handler-case
(progn (sb-posix:link (index-path hash) (fmt "groups/~a/~a" g name))
name)
(sb-posix:syscall-error (c)
(if (= (sb-posix:syscall-errno c) sb-posix:eexist)
:name-exists
(error c)))))
@ %def store-article-in-index! link-article-into-group-insist!
<<Helper procedures for the index.lisp>>=
(defun index-hash (mid)
(ironclad:byte-array-to-hex-string (string->sha256 (str:trim mid))))
(defun index-fanout (hash)
(values (subseq hash 0 2) (subseq hash 2 4)))
(defun index-path-dir (hash)
(multiple-value-bind (b1 b2) (index-fanout hash)
(fmt "index/~a/~a/" b1 b2)))
(defun index-path (hash)
(fmt "~a~a" (index-path-dir hash) hash))
(defun ensure-index-directories! (hash)
(ensure-directories-exist (index-path-dir hash)))
(defun get-mid-from-path (path)
(get-header "message-id"
(parse-headers (bytes->string (read-headers-raw path)))))
@
\section{Procedure to import the index from the file system}
What we now need is a procedure to intern a directory full of
articles. We could have a series of articles somewhere and we would
like to have them all recognized by \Lp.
<<How to create an index from the file system.lisp>>=
(defun index-from-fs! ()
(loop for path in (in-groups (directory "**/*"))
do (let* ((g (str:trim (first (last (pathname-directory path)))))
(i (str:trim (pathname-name path)))
(m (ignore-errors (str:trim (extract-mid (fetch-article g i))))))
(when (and m (> (length m) 0))
(let* ((hash (index-hash m))
(idx-path (index-path hash)))
(ensure-index-directories! hash)
;; If index file exists, verify if it shares our inode. If not, force-link it.
(cond
((probe-file idx-path)
(unless (= (handler-case (sb-posix:stat-ino (sb-posix:stat (uiop:native-namestring path)))
(sb-posix:syscall-error () 0))
(handler-case (sb-posix:stat-ino (sb-posix:stat (uiop:native-namestring idx-path)))
(sb-posix:syscall-error () -1)))
;; Overwrite stale/mismatched index entry with the correct hard link
(ignore-errors (delete-file idx-path))
(sb-posix:link (uiop:native-namestring path) idx-path)
(format t "article ~a/~a force-linked to index ~a~%" g i hash)))
(t
(handler-case
(progn
(sb-posix:link (uiop:native-namestring path) idx-path)
(format t "article ~a/~a indexed by ~a hash ~a~%" g i m hash))
(sb-posix:syscall-error (c)
(if (= (sb-posix:syscall-errno c) sb-posix:eexist)
(format t "article ~a/~a already indexed concurrently.~%" g i)
(error c)))))))))))
(defun index-from-fs!-old ()
(loop for path in (in-groups (directory "**/*"))
do (let* ((g (str:trim (first (last (pathname-directory path)))))
(i (str:trim (pathname-name path)))
(m (ignore-errors (str:trim (extract-mid (fetch-article g i))))))
(when (and m (> (length m) 0))
(let* ((hash (index-hash m))
(idx-path (index-path hash)))
(if (probe-file idx-path) ;; article exists in index: unify inodes by re-linking group file to index
(unless (= (get-file-inode path) (get-file-inode idx-path))
(delete-file path)
(sb-posix:link (uiop:native-namestring idx-path) (uiop:native-namestring path))
(format t "article ~a/~a relinked-to-existing-index ~a~%" g i hash))
(progn
(ensure-index-directories! hash)
(handler-case
(progn
(sb-posix:link (uiop:native-namestring path) idx-path)
(format t "article ~a/~a mid ~a hashes-to ~a~%" g i m hash))
(sb-posix:syscall-error (c)
(if (= (sb-posix:syscall-errno c) sb-posix:eexist)
(format t "article ~a/~a indexed due to a cross-post? EEXIST.~%" g i)
(error c)))))))))))
@
\begin{crossedblock}
When we build the index from scratch, it's important to have a
procedure capable of reading all articles in the file system and index
them one by one. This is what we implement right here. For each news
group, we get the name of the file relative to the article---that's
the numeric ID of the article---and its {\tt message-id}. That's all
we need to index it.
<<DEAD How to create an index from the file system.lisp>>=
(defun index-from-fs! ()
(loop for path in (in-groups (directory "**/*"))
do (let* ((g (str:trim (first (last (pathname-directory path)))))
(i (str:trim (pathname-name path)))
(m (str:trim (extract-mid (fetch-article g i)))))
(when (> (length m) 0)
(format t "article ~a/~a indexed by ~a~%" g i m)
(insert-index m g i)))))
(defun remake-index-from-fs ()
(index-from-fs!))
@
\end{crossedblock}
Here's a program to build the index from a UNIX shell.
<<build-index-from-fs.lisp>>=
<<Quicklisp loading preamble.lisp>>
(ql:quickload :loop :silent t)
(in-package #:loop)
<<How to create an index from the file system.lisp>>
(index-from-fs!)
@
\begin{crossedblock}
Be careful when using this program: it will build the database
[[message-id.db]], which is an operation that needs to be done only
once. Here's how to use it:
%
\begin{verbatim}
%pwd
/home/me/loop
%sbcl --script build-index-from-fs.lisp
Index built.
%ls -l message-id.db
-rw-r--r-- 1 me wheel 65536 Aug 26 13:32 message-id.db
\end{verbatim}
\end{crossedblock}
\section{How to verify the index is properly done}
<<How to verify the index.lisp>>=
(defun verify-index-inodes ()
"Iterates over all group articles and prints whether they share an inode with index/."
(loop for path in (in-groups (directory "**/*"))
do (let* ((dir-list (pathname-directory path))
(g (when dir-list (str:trim (first (last dir-list)))))
(i (pathname-name path))
(i-str (when i (str:trim i))))
;; ignore metadata and directories
(when (and g i-str (parse-integer i-str :junk-allowed t))
(let ((mid (ignore-errors (get-mid-from-path path))))
(if (or (null mid) (zerop (length (str:trim mid))))
(format t "no-mid ~a/~a couldn't find message-id~%" g i-str)
(let* ((hash (index-hash mid))
(idx-path (index-path hash))
(grp-inode (get-file-inode path))
(idx-inode (get-file-inode idx-path)))
(cond
((null idx-inode)
(stdout "no-index ~a/~a mid ~a hashes-to ~a~%"
g i-str mid idx-path))
((= grp-inode idx-inode)
(stdout "okay ~a/~a shares-inode ~a with ~a~%"
g i-str grp-inode idx-path))
(t
(stdout "mismatch ~a/~a inode ~a =/= inode ~a hash ~a~%"
g i-str grp-inode idx-inode idx-path))))))))))
(defun verify-index ()
(verify-index-inodes))
@
<<verify-index.lisp>>=
<<Quicklisp loading preamble.lisp>>
(ql:quickload :loop :silent t)
(in-package #:loop)
<<How to verify the index.lisp>>
(verify-index)
@
\section{Finding duplicates in the database}
<<How to find duplicate message-ids.lisp>>=
(defun find-duplicate-mids ()
"Displays any duplicated message-ids across all group articles."
(let ((mid-map (make-hash-table :test 'equal))
(found-dupes nil))
;; collect all articles and group by message-id
(loop for path in (in-groups (directory "**/*"))
do (let* ((dir-list (pathname-directory path))
(g (when dir-list (str:trim (first (last dir-list)))))
(i (pathname-name path))
(i-str (when i (str:trim i))))
;; process numeric article files only
(when (and g i-str (parse-integer i-str :junk-allowed t))
(let ((mid (ignore-errors (get-mid-from-path path))))
(when (and mid (> (length (str:trim mid)) 0))
;; push the (group . article-number) pair into the hash map
(push (cons g i-str) (gethash mid mid-map)))))))
;; remove duplicates
(maphash (lambda (mid locations)
(when (> (length locations) 1)
(push (cons mid locations) found-dupes)))
mid-map)
;; displays
(when found-dupes
(loop for (mid . locs) in found-dupes
do (format t "message-id: ~a~%" mid)
;; sort by group
(let ((sorted-locs (sort locs #'string-lessp :key #'car)))
(loop for (g . i) in sorted-locs
do (format t "~a/~a~%" g i)))))))
@
<<find-duplicates.lisp>>=
<<Quicklisp loading preamble.lisp>>
(ql:quickload :loop :silent t)
(in-package #:loop)
<<How to find duplicate message-ids.lisp>>
(find-duplicate-mids)
@
\section{Deletion and locking of inactive accounts}\label{sec:inactive-users}
We now implement some of the \hyperref[principles]{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
locks them. If you want to keep accounts forever, just don't
run the program. I've decided to never delete accounts that are
inactive, so I only lock them.
<<cron-remove-inactive-users.lisp>>=
<<Quicklisp loading preamble.lisp>>
(ql:quickload :loop :silent t)
(in-package #:loop)
(read-accounts!)
(remove-inactive-users!)
(write-accounts!)
@ %def cron-remove-inactive-users.lisp
The entire program is really [[remove-inactive-users!]].
<<How to remove inactive users.lisp>>=
(defun remove-inactive-users! ()
(loop for u in *accounts* do
(let ((username (account-username u)))
(cond ((and (not (locked? username))
(inactive-from-never-logged-in? username))
(post-notification
:subject (fmt "account ~a removed by Loop" username)
:body (fmt "~a didn't log in a first time (for ~a month~a) since account creation."
username *months-never-logged-in*
(plural *months-never-logged-in* "s")))
(remove-account! username)
(format t "Removed ~a due to never logging in.~%" username))
((and (not (locked? username))
(inactive-from-last-seen? username))
(post-notification
:subject (fmt "account ~a locked by Loop" username)
:body (fmt "~a disappeared for over ~a month~a."
username *months-inactive-allowed*
(plural *months-inactive-allowed* "s")))
(lock-account! username
(fmt "disappeared for over ~a months"
*months-inactive-allowed*))
(format t "Locked ~a due to long-time-no-see.~%" username))))))
@ %def remove-inactive-users!
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 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.
<<How to remove inactive users.lisp>>=
(defun remove-account! (username)
(loop for u in *accounts* do
(setf (account-friends u)
(delete username (account-friends u) :test #'equal)))
(setf *accounts*
(delete-if #'(lambda (a) (equal (account-username a) username))
*accounts*)))
(defun lock-account! (username why)
(let ((u (get-account username)))
(setf (account-pass-locked u) (account-pass u))
(setf (account-pass u) "locked")
(setf (account-pass-locked-why u) why)))
@ %def remove-account!
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. (We do
not remove this set of source code chunks because they serve as an
example of how to do a migration of this sort.)
<<How to migrate accounts without a creation date.lisp>>=
(defun loop-epoch ()
(encode-timestamp 0 0 0 0 1 1 2024))
(defun migrate-add-creation-and-post-date! ()
(read-accounts!)
(loop for u in *accounts*
do (if (not (account-creation u))
(setf (account-creation u) (timestamp-to-universal (loop-epoch)))
(setf (account-last-post u) (account-seen u))))
(write-accounts!))
@ %def migrate-add-creation-and-post-date!
Here's a program to run the migration in a UNIX shell.
<<migrate-add-creation-date.lisp>>=
<<Quicklisp loading preamble.lisp>>
(ql:quickload :loop :silent t)
(in-package #:loop)
(migrate-add-creation-and-post-date!)
(format t "Accounts rewritten.~%")
@
Now we write the procedures that discover what accounts are inactive.
<<Definition of maximum allowed inactive periods.lisp>>=
(defparameter *months-inactive-allowed* 3)
(defparameter *months-never-logged-in* 1)
@
<<How to enumerate inactive accounts.lisp>>=
(defun user-inactive? (username)
(or (inactive-from-never-logged-in? username)
(inactive-from-last-seen? username)))
(defun inactive-from-never-logged-in? (username)
(let ((u (get-account username)))
(if (ever-logged-in? username)
NIL
(inactive-from? username *months-never-logged-in*
#'(lambda () (account-creation u))))))
(defun locked? (username)
(equal "locked" (account-pass (get-account username))))
(defun inactive-from-last-post? (username)
(let ((last-post (account-last-post (get-account username)))
(creation (account-creation (get-account username))))
(inactive-from? username *months-inactive-allowed*
(if last-post
#'(lambda () last-post)
#'(lambda () creation)))))
(defun inactive-from-last-seen? (username)
(let* ((u (get-account username))
(last-seen (account-seen u))
(creation (account-creation u)))
(inactive-from? username *months-inactive-allowed*
(if last-seen
#'(lambda () last-seen)
#'(lambda () creation)))))
(defun inactive-from? (username months timestamp-source)
(declare (ignore username))
(timestamp<
(timestamp+
(universal-to-timestamp
(funcall timestamp-source)) months :month)
(now)))
(defun ever-logged-in? (username)
(account-seen (get-account username)))
(defun never-logged-in? (username)
(not (ever-logged-in? username)))
(defun list-inactive-users ()
(loop for u in *accounts* do
(format t "Username ~a is inactive? ~a~%"
(account-username u)
(user-inactive? (account-username u)))))
@
\section{Macros to ease writing}\label{sec:dsl}
These macros make up a tiny language to ease the writing of \lp. For
example, when we need to access the group database, we use
[[in-groups]]. When a certain command demands authentication, we use
[[with-auth]].
<<Macros.lisp>>=
(defmacro with-file-lock ((lock-path &key (sleep-time 0.1) (retries 50)) &body body)
(let ((lock-file (gensym "LOCK-FILE-"))
(stream (gensym "STREAM-"))
(attempt (gensym "ATTEMPT-")))
`(let ((,lock-file ,lock-path))
(unwind-protect
(progn
(loop for ,attempt from 1 to ,retries
do (handler-case
(with-open-file (,stream ,lock-file
:direction :output
:if-exists :error
:if-does-not-exist :create)
(format ,stream "~a~%" (get-universal-time))
(return))
(file-error ()
(if (= ,attempt ,retries)
(error "could not acquire lock on ~a after ~a attempts."
,lock-file ,retries)
(sleep ,sleep-time)))))
,@body)
(ignore-errors (delete-file ,lock-file))))))
(defmacro in-dir (dir &rest body)
`(let ((*default-pathname-defaults* (truename ,dir)))
(uiop:with-current-directory (,dir)
,@body)))
@
Notice that we set [[*default-pathname-defaults*]] and we set the
process' current working directory. That's not necessary because Lisp
always uses [[*default-pathname-defaults*]] and does not care about
the current working directory. We did this out of the fact that we
used to invoke [[renameat2]] through the [[cffi]], but we don't use it
any more.
<<Macros.lisp>>=
(defmacro in-tmp (&rest body) `(in-dir "tmp/" ,@body))
(defmacro in-groups (&rest body) `(in-dir "groups/" ,@body))
(defun in-group-lambda (g fn) (in-dir g (funcall fn)))
(defmacro in-group (g &rest body)
`(in-group-lambda (fmt "groups/~a/" ,g) #'(lambda () ,@body)))
(defmacro with-group (g r &rest body)
(let ((g-var (gensym))
(r-var (gensym)))
`(let ((,g-var ,g)
(,r-var ,r))
(if (not (group? ,g-var))
(make-response :code 411 :request ,r-var
:data (fmt "no such group ``~a''" ,g-var))
(progn ,@body)))))
(defmacro with-n-args (n r &rest body)
(let ((args-var (gensym))
(message-var (gensym))
(n-var n))
`(let ((,args-var (request-args r))
(,message-var ,(fmt "bad arguments: needs exactly ~a" n-var)))
(if (not (= ,n-var (length ,args-var)))
(make-response :code 400 :request ,r :data ,message-var)
(progn ,@body)))))
(defmacro with-group-set (&rest body)
(let ((g-var (gensym)))
`(let ((,g-var (client-group *client*)))
(if (not ,g-var)
(bad-input r "must say GROUP first")
,@body))))
(defmacro with-auth (&rest body)
`(if (not (auth?))
(make-response :code 400 :data "You must authenticate first.")
(progn ,@body)))
@ %def in-groups with-group with-n-args with-group-set with-auth
\section{Other procedures}
Of small importance, they have nothing.
<<Little procedures.lisp>>=
(defun get-file-inode (path)
"Returns the inode number for PATH or NIL if the file doesn't exist."
(handler-case
(sb-posix:stat-ino (sb-posix:stat (uiop:native-namestring path)))
(sb-posix:syscall-error () nil)))
(defun conforms-to? (s re &optional error-msg)
"Does string S conform to regular expression RE?"
(let ((okay? (cl-ppcre:scan-to-strings re s)))
(if okay?
(values t nil)
(values nil (or error-msg (fmt "must match ~a" re))))))
(defun print/finish (&rest args)
(apply #'format (cons t args))
(finish-output))
(defun word-plural (n word)
(let ((table '(("doesn't" . "don't")
("newsgroup" . "newsgroups"))))
(let ((w (assoc word table :test #'string=)))
(if (not w)
(str:concat word "s") ;; assume s as suffix
(if (< n 2) (car w) (cdr w))))))
(defun plural (v suffix)
(if (> v 1) suffix ""))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun fmt (cstr &rest args)
(apply #'format nil (list* cstr args))))
(defun out (stream &rest args)
(apply #'format (cons stream args)))
(defun stderr (&rest args)
(when *debug*
(apply #'out (cons *error-output* args))
(finish-output *error-output*)))
(defun stdout (&rest args)
(apply #'out (list* *standard-output* args)))
(defun println (&rest args)
(apply #'out (list* *standard-output* (str:concat (car args) "~%") (cdr args))))
(defun bad-input (r msg &key code)
(make-response :code (or code 400) :data msg :request r))
(defun integer->string (n)
(fmt "~a" n))
(defun crlf ()
(vector 13 10))
(defun crlf-string ()
(fmt "~c~c" #\return #\linefeed))
(defmacro mac (&rest body)
`(macroexpand-1 ,@body))
@ %def bad-input crlf crlf-string
\section{Tests}
I removed the tests. We have done a major rewrite.
\begin{crossedblock}
I studied the minimum to be able to add these tests as we comprehend
better the direction in which we're going. A test system is essential
for us to trust we can move forward without breaking important past
decisions in the code. We should not include these tests in
production code as we are doing right now. Divert them to a tests
package or something that makes more sense. To run the tests, you
need to invoke [[lisp-unit:run-tests]]. I believe that invoking it in
a script will make all tests run. Oh, that should be included the
binary, too, so that we can always test an archived project. That's a
good idea. Make it a clingon option on the command line, though
remember we will get rid of clingon. Of course, by including tests in
the executable, we should isolate all the tests here. I know
how---just define a test package and isolate it all in it. Packages
are for namespace isolation. Lisp's ``systems'' are the type of
packaging meant for loading. Lisp's ``packages'' are merely namespace
isolation. Our test package should use \lp's package, so that we can
use any of the procedures under testing. When we define a variable,
it will be defined in the test package, not in \lp's, but when we are
in \lp's package, we see no names of the test package. It's simple
and a good solution.
When testing, it's important for us not to clutter a production
system---we will want to run tests on production systems. So what we
need to do is to wrap any file system modification to a certain other
directory in which \lp's tests will find the groups directory in
place. Making that happen is as simple as changing
[[*default-pathname-defaults*]].
<<Test procedures.lisp>>=
(setq lisp-unit:*print-failures* t)
(define-test dispatching
(assert-true (equalp (empty-response) (dispatch (make-request)))))
(defun unix->nntp (s)
"I substitute \n for \r\n"
(str:replace-all (fmt "~a" #\linefeed) (crlf-string) s))
(defvar a-post (unix->nntp "From: root
Message-id: <pwtdldytefplntosymvo@loop>
Subject: test
Newsgroups: local.test
Quickest test of the West.
"))
(defvar a-bad-post (unix->nntp "From: root
Message-id: <pwtdldytefplntosymvp@loop>
Subject: a bad test
Newsgroups: local.test, bad.newsgroup
A bad test from the biggest mouth of the south.
"))
@ %def
\end{crossedblock}
\section{How to produce the binary executable}
Just say {\tt make loop} to your shell.
<<build-exe.lisp>>=
<<Quicklisp loading preamble.lisp>>
(ql:quickload :loop)
(sb-ext:save-lisp-and-die #P"loop"
:toplevel #'loop:main
:executable t
:save-runtime-options t)
@
<<Quicklisp loading preamble.lisp>>=
#-quicklisp
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
(user-homedir-pathname))))
(when (probe-file quicklisp-init)
(load quicklisp-init)))
@
\section{How to get a log of \lp's communication}
If you invoke \lxxp\ with option [[--logging]], you get logging on
[[stderr]]:
%
\begin{verbatim}
$ ./loop -s --logging > /dev/null
@>>> 200 Welcome! Say ``help'' for a menu.
quit
@<<< quit
@>>> 205 Good-bye.
\end{verbatim}
But remember that \lp\ runs various processes in parallel, so the
question now is how to unify all processes' logs into a single one.
We can't use
\href{https://cr.yp.to/daemontools/multilog.html}{multilog}, for
instance. The easiest solution now is to send all messages to {\tt
syslog}. FreeBSD and GNU systems come with a program called {\tt
logger}, which is able to write messages to {\tt syslog}. If you're
using \href{https://cr.yp.to/daemontools/svscan.html}{{\tt svscan}},
then you can use a program such as
%
\begin{verbatim}
$ cat log/run
#!/bin/sh
exec /usr/bin/logger -i -t loop
\end{verbatim}
%
as your {\tt log/run} script. See {\tt logger(1)} for more
information. Using {\tt logger(1)} means you need to set up {\tt
syslog}, too. By the default, {\tt logger(1)} will use the {\em
facility} {\tt user} and the {\em level} {\tt notice}. So you can
specify in {\tt syslog.conf} the selector {\tt user.notice} and
specify a log file such as {\tt /var/log/loop.log}. See {\tt
syslog.conf(5)} and {\tt newsyslog(1)} for more information.
\section{Package {\tt loop.lisp} as the compiler needs it}
We now put together all source code chunks in the order the compiler
needs to read it. One thing to keep in mind here is---I wonder if
people that might read this source code would read the literate
programming \LaTeX\ output or would they read [[loop.lisp]] directly.
For literate programmers, it doesn't matter how [[loop.lisp]] turns
out because only the compiler reads [[loop.lisp]]. But if we care
about anyone who might read [[loop.lisp]], then we should perhaps tell
our literate programming tools to generate a nice-looking file. For
instance, I declare global variables in the chunks where it's used.
But for someone reading [[loop.lisp]] directly, it is perhaps better
if they would see all global variables at the top of the file. That's
something to think about.
<<loop.lisp>>=
;;; -*- mode: LISP; syntax: COMMON-LISP; package: LOOP; -*-
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload
'(<<List of packages to be loaded.lisp>>)
:silent t))
(clsql:file-enable-sql-reader-syntax)
(defpackage #:loop
(:use :common-lisp :local-time)
(:import-from :lisp-unit define-test assert-true)
(:import-from :org.shirakumo.filesystem-utils
directory-p list-directories list-files)
(:import-from :sb-sys interactive-interrupt)
(:export :main))
(in-package #:loop)
<<Global variables.lisp>>
<<Table of commands.lisp>>
<<Macros.lisp>>
<<Little procedures.lisp>>
<<Loop REPL.lisp>>
<<Procedures for requests and responses.lisp>>
<<How to remove inactive users.lisp>>
<<How to enumerate inactive accounts.lisp>>
<<How to migrate accounts without a creation date.lisp>>
<<How to read the head of articles.lisp>>
<<How to parse articles.lisp>>
<<How to stream off articles.lisp>>
<<How to index articles.lisp>>
<<Dispatching of commands.lisp>>
<<Command capabilities.lisp>>
<<Command authinfo.lisp>>
<<Command mode reader.lisp>>
<<Commands head, body, article.lisp>>
<<Command xover.lisp>>
<<Command xhdr.lisp>>
<<Command group.lisp>>
<<Command list.lisp>>
<<Command listgroup.lisp>>
<<Command help.lisp>>
<<Command quit.lisp>>
<<Command date.lisp>>
<<Command post.lisp>>
<<Command create-group.lisp>>
<<Command create-account.lisp>>
<<Command login.lisp>>
<<Command passwd.lisp>>
<<Command users.lisp>>
<<Command dd.lisp>>
<<Command repl.lisp>>
<<Command search.lisp>>
<<Broadcasting.lisp>>
<<Command-line parsing.lisp>>
<<Main loop.lisp>>
<<Test procedures.lisp>>
@ %def
<<Global variables.lisp>>=
(defparameter *debug* t)
<<Representation of accounts.lisp>>
<<Representation of a client.lisp>>
<<Representation of requests and responses.lisp>>
<<Representation of commands.lisp>>
<<Representation of articles.lisp>>
<<Definition of maximum allowed inactive periods.lisp>>
<<Global variable that decides whether to enable the NNTP REPL.lisp>>
<<Global variable to hold the connections spoken lines.lisp>>
@
On which packages do we depend?
<<List of packages to be loaded.lisp>>=
:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon
:filesystem-utils :ironclad/digest/sha256
@
The \lp\ system definition:
<<loop.asd>>=
;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*-
(asdf:defsystem :<<Name>>
:version "<<Version>>"
:description "<<Description>>"
:depends-on (<<List of packages to be loaded.lisp>>)
:components ((:file "loop")
(:file "version")))
@
\section{Other source code}
The shell script {\tt format-def} is invoked whenever we build any
Lisp source code. That's to format the source code a bit better for
readers that will be reading it directly. It is not what we do. We
read the documentation in PDF format and we work on the NOWEB file
{\tt loop.nw}. But we know that potential readers will not do the
same and will hack {\tt loop.lisp} directly. Paying respect to these
readers, we try to format Lisp source code as best as possible. So we
do two things: first, we produce the final source code in an order
that should produce no warnings during compilation; second, we make
sure there's one and only one blank line between procedure or macro
definition. We don't add a blank line between global variables.
The following shell script does the job. The first {\tt sed} program
finds our definitions of interest and inserts a new blank line before
the definition. Such action makes function definitions separated by
two blank lines in some cases. We then remove the excess with the
second program. Notice we need the {\tt -E} option because we're
using the {\tt \textbar} metacharacter.
The second program finds a blank line as its first step. Then we say
{\tt N} to expand the pattern space to include the next line. Then we
delete the {\em first} blank line and not the second---that's what the
{\tt D} command does. This strategy is explained by Dale Dougherty
and Arnold Robbins in ``sed \& awk'' second edition, pages 112--114.
<<format-def.sh>>=
#!/bin/sh
usage()
{
printf 'usage: %s [file.lisp]\n' $0
exit 1
}
sed -E '/^\(defun |\(defmacro /{
i\
}' "$@" | \
sed '/^[ \t]*$/{
N
/^[ \t]*\n$/D
}'
@
When we make a new release of \lp, we like to name its version as the
tip of the source code repository. We get the information usually
with a command line such as
%
\begin{verbatim}
$ git log --oneline | head -1 | awk '{print $1}'
52663d1
\end{verbatim}
%
We achieve this with [[version.lisp]], which we generate before any
release. This a bit of meta source code we use is included in a meta
Makefile we maintain. You could assume that [[version.lisp]] is
manually written before we release a new version. When \Lp\ displays
the welcome banner, the procedure [[welcome-message]] replaces the
string [[HASH]] with the hash spelled out in [[version.lisp]].
\section*{Index of chunks}
\nowebchunks
\section*{Index of names}
\nowebindex
\end{document}
Reference in a new issue View git blame Copy permalink