3993 lines
156 KiB
Text
3993 lines
156 KiB
Text
% -*- 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{amsmath,amsthm,amssymb}
|
||
\allowdisplaybreaks
|
||
\usepackage{lmodern}
|
||
\usepackage{noweb}
|
||
%% \usepackage[backend=biber]{biblatex}
|
||
%% \addbibresource{refs.bib}
|
||
%% \renewcommand{\cite}{\parencite}
|
||
% \usepackage[hyperref]{xcolor}
|
||
\usepackage[colorlinks=true,citecolor=]{hyperref} % linkcolor=red
|
||
|
||
\makeatletter
|
||
\let\old@hyperlink\hyperlink
|
||
\protected\def\hyperlink#1#2{%
|
||
\def\nw@target{#1}%
|
||
\def\nw@badtarget{noweb.}%
|
||
\ifx\nw@target\nw@badtarget
|
||
#2% Output plain text if target is empty "noweb."
|
||
\else
|
||
\old@hyperlink{#1}{#2}% Otherwise create normal hyperlink
|
||
\fi
|
||
}
|
||
\makeatother
|
||
|
||
%% The root cause is a flaw in how noweb interacts with hyperref when
|
||
%% generating cross-reference footers for code chunks that span page
|
||
%% ranges or multiple definitions.
|
||
%%
|
||
%% Empty Anchor Lookup: When noweave outputs chunk footers (such
|
||
%% as "used in chunks 28–30" via \nwused), noweb attempts to look
|
||
%% up a unique target ID for the target chunk. Because
|
||
%% range-spanning chunks lack a single discrete anchor target, the
|
||
%% lookup returns an empty string ("").
|
||
%%
|
||
%% Naïve Target Concatenation: noweb constructs the link target by
|
||
%% appending the target ID directly to its default prefix
|
||
%% ("noweb." + ""), resulting in the literal string noweb..
|
||
%%
|
||
%% Hyperref Target Failure: noweb passes
|
||
%% \hyperlink{noweb.}{28--30} to hyperref. Because no destination
|
||
%% named noweb. was ever registered in the document, hyperref
|
||
%% flags it as a missing target.
|
||
%%
|
||
%% Lack of Sanitization in noweb.sty: Unlike modern LaTeX
|
||
%% packages, legacy noweb.sty does not check whether a tag ID is
|
||
%% empty before wrapping the display text in a \hyperlink.
|
||
%%
|
||
%% Intercepting \hyperlink in your preamble fixes this at the root by
|
||
%% catching any target evaluating strictly to noweb. and stripping the
|
||
%% hyperlink wrapper, letting the plain text (28--30) render cleanly
|
||
%% without triggering hyperref.
|
||
|
||
\makeatletter
|
||
\let\old@hyper@link\hyper@link
|
||
\def\hyper@link#1#2#3{%
|
||
\def\testtarget{#2}%
|
||
\def\badtarget{noweb.}%
|
||
\ifx\testtarget\badtarget
|
||
\typeout{^^J==================================================}%
|
||
\typeout{ROOT CAUSE FOUND AT TEX LINE: \the\inputlineno}%
|
||
\typeout{Link Type: #1 | Target: '#2' | Text: '#3'}%
|
||
\typeout{==================================================^^J}%
|
||
\fi
|
||
\old@hyper@link{#1}{#2}{#3}%
|
||
}
|
||
\makeatother
|
||
|
||
\noweboptions{longchunks,smallcode}
|
||
\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}
|
||
%\hypertarget{noweb.}{} % fixes the bug
|
||
\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 ()
|
||
'("Subject:"
|
||
"From:"
|
||
"Date:"
|
||
"Message-ID:"
|
||
"References:"
|
||
"Bytes:"
|
||
"Lines:"))
|
||
|
||
(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."))
|
||
@
|
||
|
||
\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))
|
||
@
|
||
|
||
\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))
|
||
@
|
||
|
||
\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 post-from-path (tmp-path)
|
||
(let* ((headers-raw (read-headers-raw tmp-path))
|
||
(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-path 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~%"))))
|
||
|
||
(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)
|
||
(post-from-path tmp)
|
||
(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 441 :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)))
|
||
@
|
||
|
||
<<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)))
|
||
(post-from-path tmp))
|
||
(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" :code 412)
|
||
,@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.
|
||
"))
|
||
@
|
||
\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>>
|
||
@
|
||
|
||
<<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}
|