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

Uses polymode in the GNU EMACS, not noweb-mode any longer.

Browse source
This commit is contained in:
Circling Skies 2026-06-09 23:15:44 -03:00
parent 4412496fb6
commit efa5ee3ccd
3 changed files with 239 additions and 220 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

40
Anyfile
View file

@ -6,27 +6,28 @@ default: all
all: loop.exe loop.lisp loop.asd scripts/build-exe.lisp \ all: loop.exe loop.lisp loop.asd scripts/build-exe.lisp \
scripts/build-index-from-fs.lisp \ scripts/build-index-from-fs.lisp \
scripts/cron-remove-inactive-users.lisp \ scripts/cron-remove-inactive-users.lisp \
scripts/migrate-add-creation-date.lisp scripts/migrate-add-creation-date.lisp \
tags
tags: loop.nw loop.lisp
etags --language=lisp loop.lisp
loop.exe: scripts/build-exe.lisp loop.lisp loop.asd loop.nw loop.exe: scripts/build-exe.lisp loop.lisp loop.asd loop.nw
sbcl --script scripts/build-exe.lisp sbcl --script scripts/build-exe.lisp
(test -f loop.exe && cmp loop loop.exe) || cp loop loop.exe (test -f loop.exe && cmp loop loop.exe) || cp loop loop.exe
loop.lisp: loop.nw format-def loop.lisp: loop.nw format-def
(any tangle -Rloop.lisp < loop.nw | sh format-def | \ (no tangle -Rloop.lisp < loop.nw | sh format-def > loop.tmp || \
dos2unix > loop.tmp || \
(rm loop.tmp && exit 1)) && \ (rm loop.tmp && exit 1)) && \
mv loop.tmp loop.lisp mv loop.tmp loop.lisp
format-def: loop.nw format-def: loop.nw
(any tangle -Rformat-def < loop.nw | \ (no tangle -Rformat-def.sh < loop.nw > format-def.tmp || \
dos2unix > format-def.tmp || \
(rm format-def.tmp && exit 1)) && \ (rm format-def.tmp && exit 1)) && \
mv format-def.tmp format-def mv format-def.tmp format-def
make-release: loop.nw make-release: loop.nw
(any tangle -Rmake-release < loop.nw | \ (no tangle -Rmake-release.sh < loop.nw > make-release.tmp || \
dos2unix > make-release.tmp || \
(rm make-release.tmp && exit 1)) && \ (rm make-release.tmp && exit 1)) && \
mv make-release.tmp make-release mv make-release.tmp make-release
@ -35,47 +36,48 @@ release: make-release
loop.nw > loop.tmp && mv loop.tmp loop.nw loop.nw > loop.tmp && mv loop.tmp loop.nw
loop.asd: loop.nw loop.asd: loop.nw
(any tangle -Rloop.asd < loop.nw | dos2unix > loop-asd.tmp || \ (no tangle -Rloop.asd < loop.nw > loop-asd.tmp || \
(rm loop-asd.tmp && exit 1)) && \ (rm loop-asd.tmp && exit 1)) && \
mv loop-asd.tmp loop.asd mv loop-asd.tmp loop.asd
scripts/build-exe.lisp: loop.asd loop.lisp loop.nw scripts/build-exe.lisp: loop.asd loop.lisp loop.nw
(any tangle -Rbuild-exe.lisp < loop.nw | dos2unix > build-exe.tmp || \ (no tangle -Rbuild-exe.lisp < loop.nw > build-exe.tmp || \
(rm build-exe.tmp && exit 1)) && \ (rm build-exe.tmp && exit 1)) && \
mv build-exe.tmp scripts/build-exe.lisp mv build-exe.tmp scripts/build-exe.lisp
scripts/build-index-from-fs.lisp: loop.nw scripts/build-index-from-fs.lisp: loop.nw
(any tangle -Rbuild-index-from-fs.lisp < loop.nw | dos2unix > \ (no tangle -Rbuild-index-from-fs.lisp < loop.nw > \
build-index-from-fs.tmp || \ build-index-from-fs.tmp || \
(rm build-index-from-fs.tmp && exit 1)) && \ (rm build-index-from-fs.tmp && exit 1)) && \
mv build-index-from-fs.tmp scripts/build-index-from-fs.lisp mv build-index-from-fs.tmp scripts/build-index-from-fs.lisp
scripts/cron-remove-inactive-users.lisp: loop.nw scripts/cron-remove-inactive-users.lisp: loop.nw
(any tangle -Rcron-remove-inactive-users.lisp < loop.nw | dos2unix > \ (no tangle -Rcron-remove-inactive-users.lisp < loop.nw > \
cron-remove-inactive-users.tmp || \ cron-remove-inactive-users.tmp || \
(rm cron-remove-inactive-users.tmp && exit 1)) && \ (rm cron-remove-inactive-users.tmp && exit 1)) && \
mv cron-remove-inactive-users.tmp \ mv cron-remove-inactive-users.tmp \
scripts/cron-remove-inactive-users.lisp scripts/cron-remove-inactive-users.lisp
scripts/migrate-add-creation-date.lisp: loop.nw scripts/migrate-add-creation-date.lisp: loop.nw
(any tangle -Rmigrate-add-creation-date.lisp < loop.nw | dos2unix > \ (no tangle -Rmigrate-add-creation-date.lisp < loop.nw > \
migrate-add-creation-date.tmp || \ migrate-add-creation-date.tmp || \
(rm migrate-add-creation-date.tmp && exit 1)) && \ (rm migrate-add-creation-date.tmp && exit 1)) && \
mv migrate-add-creation-date.tmp \ mv migrate-add-creation-date.tmp \
scripts/migrate-add-creation-date.lisp scripts/migrate-add-creation-date.lisp
run: loop.nw # run: loop.nw
(any tangle -Rrun < loop.nw | dos2unix > run.tmp || \ # (no tangle -Rrun < loop.nw > run.tmp || \
(rm run.tmp && exit 1)) && \ # (rm run.tmp && exit 1)) && \
mv run.tmp run && \ # mv run.tmp run && \
chmod 0755 run # chmod 0755 run
loop.tex: loop.nw loop.tex: loop.nw
any weave -delay -index loop.nw | dos2unix > loop.tex no weave -delay -index loop.nw > loop.tex
loop.pdf: loop.tex loop.pdf: loop.tex
latexmk -pdf loop latexmk -pdf loop
clean: clean:
rm -f loop loop.exe loop.asd loop.lisp loop.tex loop.pdf \ rm -f loop loop.exe loop.asd loop.lisp loop.tex loop.pdf \
*.fasl *.db .*~ *~ *.out *.aux *.log *.fls *.fdb_latexmk *.fasl *.db .*~ *~ *.out *.aux *.log *.fls *.fdb_latexmk \
TAGS

48
loop.lisp
View file

@ -620,9 +620,16 @@
(make-response :multi-line 'yes :code code (make-response :multi-line 'yes :code code
:request r :data (funcall get-data a)))))) :request r :data (funcall get-data a))))))
(sb-posix:syscall-error (c) (sb-posix:syscall-error (c)
(make-response (let ((msg (format nil "article ~a/~a: ~a" g i c)))
:code 400 :request r (stderr msg)
:data (format nil "article ~a/~a: ~a" g i c))))) (make-response
:code 400 :request r :data msg)))
(error (c)
(let ((msg (format nil "unexpected condition when reading article ~a/~a: ~a" g i c)))
(stderr msg)
(make-response
:code 400 :request r
:data msg)))))
(defun cmd-next (r) (defun cmd-next (r)
(with-auth (with-auth
@ -1251,23 +1258,24 @@
maximizing (length (account-username u)))) maximizing (length (account-username u))))
(defun list-users () (defun list-users ()
(read-accounts!) (mapcar
(mapcar #'(lambda (row) (cadr row)) #'(lambda (row) (cadr row))
(sort (sort
(loop for u in *accounts* (loop for u in *accounts*
collect (list (account-username u) collect (list
(fmt "~v@a~a, ~a, invited ~a" (account-username u)
(size-of-longest-username) (fmt "~v@a~a, ~a, invited ~a"
(account-username u) (size-of-longest-username)
(if (locked? (account-username u)) (account-username u)
(fmt " (account locked: ~a)" (if (locked? (account-username u))
(account-pass-locked-why 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))) (if (last-time-seen (account-username u))
"never logged in") (fmt "last seen on ~a" (last-time-seen (account-username u)))
(or (account-friends u) "nobody")))) "never logged in")
#'string<= :key #'(lambda (row) (car row))))) (or (account-friends u) "nobody"))))
#'string<= :key #'(lambda (row) (car row)))))
(defun universal-to-human (s) (defun universal-to-human (s)
(format-timestring (format-timestring

371
loop.nw
View file

@ -1,4 +1,7 @@
% -*- mode: noweb; noweb-default-code-mode: lisp-mode; -*- % -*- mode: poly-noweb; -*-
% HELLO
%% %% % -*- mode: noweb; -*-
%% %% %% noweb-default-code-mode: lisp-mode;
\documentclass[a4paper,11pt]{article} \documentclass[a4paper,11pt]{article}
\usepackage[text={6.75in,10in},centering]{geometry} \usepackage[text={6.75in,10in},centering]{geometry}
@ -71,9 +74,9 @@ 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 form a circle. When we decide to add another person to this
quickly-made conference by e-mail, sometimes we use a well-known 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 idiom---``adding John to the loop''. We add John's e-mail address to
the list of destinaries. So long as everyone replies to everyone, the list of destinataries. So long as everyone replies to everyone,
John, too, will start getting all the messages. If anyone violates John too will get all the messages. If anyone violates this rule of
this rule of replying to everyone involved, the loop is broken. replying to everyone involved, the loop is broken.
\begin{figure}[!htb] \begin{figure}[!htb]
\centering \includegraphics[width=0.8\linewidth]{images/gnus-summary.png} \centering \includegraphics[width=0.8\linewidth]{images/gnus-summary.png}
@ -98,7 +101,7 @@ 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 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 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 to ask for more technology such as mailing lists. A mailing list is
nothing by an automated version of this idea of writing to various nothing but an automated version of this idea of writing to various
people at once. When the mailing address is written to, a program people at once. When the mailing address is written to, a program
resends the message to all subscribers of the mailing list and, this resends the message to all subscribers of the mailing list and, this
way, the conference takes place. way, the conference takes place.
@ -107,29 +110,30 @@ But \lp\ has nothing to do with e-mail. \Lp\ uses a communication
strategy---called a ``protocol''---that is even older than the web strategy---called a ``protocol''---that is even older than the web
itself. The web started out around 1989--1990 and the protocol 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 \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 for UNIX to UNIX V7, which was UUCP-ready, an acronym that stands for ``UNIX to
UNIX copy. It's both a protocol and a set of programs for copying UNIX copy''. UUCP is both a protocol and a set of programs for
files between UNIX systems. People begun exchanging messages by copying files between UNIX systems. People began exchanging messages
copying files between machines. The idea eventually evolved into a by copying files between machines. The idea of using UUCP for
protocol called NNTP---Network News Transfer Protocol---, which is the exchanging messages eventually evolved into a protocol called
protocol used by \lp. (The protocol used to be called Netnews NNTP---Network News Transfer Protocol---, which is the protocol used
Transfer Protocol.) Since e-mail was already daily practice of by \lp. (The protocol used to be called Netnews Transfer Protocol.)
members of the Internet back then, many things from e-mail were taken Since e-mail was already daily practice of members of the Internet
by the NNTP designers. So, an NNTP message looks a lot like an e-mail back then, many things from e-mail were taken by the NNTP designers.
message and the two---NNTP and SMTP (the protocol used by So, an NNTP message looks a lot like an e-mail message and the
e-mail)---can often mingle seamlessly. The impression we get from two---NNTP and SMTP (the protocol used by e-mail)---can often mingle
using NNTP is that we're sending e-mail to a certain group of people. seamlessly. The impression we get from using NNTP is that we're
It's as though the message goes into a collective mailbox and anyone sending e-mail to a certain group of people. It's as though the
interested in that mailbox reads the messages there. If anyone would message goes into a collective mailbox and anyone interested in that
like to reply to a message, they do so and, this way, communication mailbox reads the messages there. If anyone would like to reply to a
flows among the interested crowd. If anyone would like to leave the message, they do so and, this way, communication flows among the
group, nothing is needed---the person just doesn't go back to read any interested crowd. If anyone would like to leave the group, nothing is
more messages. Unlike mailing lists, there is no need to formally needed---the person just doesn't go back to read any more messages.
commit to reading one of these collective mailboxes and no need to Unlike mailing lists, there is no need to formally commit to reading
formally notify anyone or any system that you're not interested in one of these collective mailboxes and no need to formally notify
that group any longer. These collective mailboxes are called ``news anyone or any system that you're not interested in that group any
groups'' and are often written as ``newsgroups''. And the messages longer. These collective mailboxes are called ``news groups'' and are
posted to these newsgroups are called ``articles''. 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. 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 Anyone could write a program capable of speaking NNTP. There are many
@ -140,7 +144,7 @@ network news via NNTP.
\section*{Principles for a discussion group}\label{principles} \section*{Principles for a discussion group}\label{principles}
\pdfbookmark[1]{Principles for a discussion group}{principles} We \pdfbookmark[1]{Principles for a discussion group}{principles} We
believe a discussion group should be small and grow slowly. By believe a discussion group should be small and grow slowly. By
``slowly'', we mean that each member comes in through an invitation. ``slowly'' we mean that each member comes in through an invitation.
This way, the group being closed by definition, we keep spam out and This way, the group being closed by definition, we keep spam out and
give members a certain sense of privilege. A discussion group should 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 be formed by interested people. If a participant doesn't log-in for a
@ -148,11 +152,11 @@ certain period of time, \lp\ locks the participant's account---see
Section \ref{sec:inactive-users}. The account can be reactivated, but Section \ref{sec:inactive-users}. The account can be reactivated, but
it will take asking another participant (with an active account) to do it will take asking another participant (with an active account) to do
so. In other words, there's an encouragement for an uninterested so. In other words, there's an encouragement for an uninterested
member not to come back to the \lp. The idea is to keep a certain 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 cohesion in the discussion groups. When an account is locked or
unlocked, an article is posted to the group {\tt local.control.news}, unlocked, an article is posted to the group {\tt local.control.news},
so everyone knows who is leaving and arriving. This way, participants so everyone knows who is leaving and arriving. This way, participants
get to have an idea of who is reading them. get to have an idea of who is reading, who is watching them.
Each invitation comes with a certain responsibility: it's possible to Each invitation comes with a certain responsibility: it's possible to
see who invited who. If {\tt BOB} misbehaves, everyone gets to see see who invited who. If {\tt BOB} misbehaves, everyone gets to see
@ -403,7 +407,7 @@ there remains a \verb|\n| or \verb|\r\n| in the [[*standard-input*]],
which we need to wipe out, or [[nntp-read-line]] will consume an empty which we need to wipe out, or [[nntp-read-line]] will consume an empty
line, which is what causes that 400 response. line, which is what causes that 400 response.
<<Loop's REPL>>= <<Loop's REPL.lisp>>=
(defun repl (r) (defun repl (r)
(in-package :loop) (in-package :loop)
(loop (loop
@ -441,12 +445,11 @@ 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 and an article; it's has authenticated itself or not yet. So we need
a global structure to annonate the client's state. a global structure to annonate the client's state.
<<Representation of a client>>= <<Representation of a client.lisp>>=
(defstruct client group (article 1) (username "ANONYMOUS") (auth? 'no)) (defstruct client group (article 1) (username "ANONYMOUS") (auth? 'no))
(defparameter *client* (make-client)) (defparameter *client* (make-client))
@ %def client *client* @ %def client *client*
\section{Representation of a command} \section{Representation of a command}
What does a client typically tell \lp? A client typically sends What does a client typically tell \lp? A client typically sends
@ -457,12 +460,12 @@ commands, which is essentially what the user sees when ask for
\verb|HELP|. (Be aware that some clients use the output of \verb|HELP|. (Be aware that some clients use the output of
\verb|HELP|. For example, Gnus v5.13.) \verb|HELP|. For example, Gnus v5.13.)
<<Representation of commands>>= <<Representation of commands.lisp>>=
(defstruct command fn verb description) (defstruct command fn verb description)
(defparameter *commands-assoc* nil) (defparameter *commands-assoc* nil)
@ @
<<Table of commands>>= <<Table of commands.lisp>>=
(defun table-of-commands () (defun table-of-commands ()
`(("GROUP" ,#'cmd-group "sets the current group") `(("GROUP" ,#'cmd-group "sets the current group")
("NEXT" ,#'cmd-next "increments the article pointer") ("NEXT" ,#'cmd-next "increments the article pointer")
@ -529,12 +532,12 @@ 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 \verb|code| in the response. Long responses end with a period and we
mark such responses with [[multi-line]]. mark such responses with [[multi-line]].
<<Representation of requests and responses>>= <<Representation of requests and responses.lisp>>=
(defstruct request verb args said) (defstruct request verb args said)
(defstruct response code data request multi-line) (defstruct response code data request multi-line)
@ @
<<Procedures for requests and responses>>= <<Procedures for requests and responses.lisp>>=
(defun empty-response () (make-response :code 400 :data "I beg your pardon?")) (defun empty-response () (make-response :code 400 :data "I beg your pardon?"))
(defun prepend-response-with (message r) (defun prepend-response-with (message r)
(make-response (make-response
@ -546,7 +549,7 @@ mark such responses with [[multi-line]].
Here's how to send a [[response]] to a client. Here's how to send a [[response]] to a client.
<<Procedures for requests and responses>>= <<Procedures for requests and responses.lisp>>=
(defun append-crlf-if-needed (seq) (defun append-crlf-if-needed (seq)
(cond (cond
((stringp seq) ((stringp seq)
@ -585,7 +588,7 @@ It is not fine, however, when it's running in production. But, in
production, {\tt (interactive-stream-p s)} will always be false. How production, {\tt (interactive-stream-p s)} will always be false. How
else should we handle this? else should we handle this?
<<Procedures for requests and responses>>= <<Procedures for requests and responses.lisp>>=
(defun my-write (ls-of-bytes s) (defun my-write (ls-of-bytes s)
(if (interactive-stream-p s) (if (interactive-stream-p s)
(write-sequence (mapcar #'code-char ls-of-bytes) s) (write-sequence (mapcar #'code-char ls-of-bytes) s)
@ -606,7 +609,7 @@ says {\tt QUIT}, then we should identify it and terminate \lp's
execution. That's even [[send-response!]] returns the [[request]] execution. That's even [[send-response!]] returns the [[request]]
itself---so we can cascade actions based on a user's request. itself---so we can cascade actions based on a user's request.
<<Main loop>>= <<Main loop.lisp>>=
(defun main-loop () (defun main-loop ()
(loop (loop
(let* ((bs (nntp-read-line)) (let* ((bs (nntp-read-line))
@ -669,7 +672,7 @@ The commands themselves we call {\tt verbs} and everything else the
user types we call {\tt args}. Observe that upper and lower case user types we call {\tt args}. Observe that upper and lower case
letters are equivalent in request verbs. letters are equivalent in request verbs.
<<Procedures for requests and responses>>= <<Procedures for requests and responses.lisp>>=
(defun parse-request (r) (defun parse-request (r)
(let* ((collapsed-s (str:collapse-whitespaces (request-said r))) (let* ((collapsed-s (str:collapse-whitespaces (request-said r)))
(ls (str:split " " collapsed-s :omit-nulls 'please))) (ls (str:split " " collapsed-s :omit-nulls 'please)))
@ -686,11 +689,16 @@ letters are equivalent in request verbs.
We're using the clingon library as per Vincent Dardel suggestion in We're using the clingon library as per Vincent Dardel suggestion in
``The Common Lisp Cookbook''. We begin with writing a description of ``The Common Lisp Cookbook''. We begin with writing a description of
the program and options it understands. XXX: notice I don't know how the program and options it understands. Notice I don't know how to
to support a two-argument option, so I hacked a solution away. What support a two-argument option, so I hacked a solution away. What we
we need to is to implement a new option. The library is extensible. need to 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>>= <<Command-line parsing.lisp>>=
(defun cli/options () (defun cli/options ()
(list (list
(clingon:make-option (clingon:make-option
@ -731,7 +739,7 @@ We implement first the procedures that handle options that represent
an entire program. For example, saying [[--list-accounts]] is like an entire program. For example, saying [[--list-accounts]] is like
running a program [[./list-accounts]]. running a program [[./list-accounts]].
<<Command-line parsing>>= <<Command-line parsing.lisp>>=
(defun cli/list-accounts () (defun cli/list-accounts ()
(println (str:join (crlf-string) (list-users)))) (println (str:join (crlf-string) (list-users))))
@ -767,7 +775,7 @@ that because of the design of the [[clingon]] library, command-line
parsing becomes the main procedure of \lp. In other words, \lp's parsing becomes the main procedure of \lp. In other words, \lp's
service starts with [[server-start]]. service starts with [[server-start]].
<<Command-line parsing>>= <<Command-line parsing.lisp>>=
(defun cli/main-with-handlers (cmd) (defun cli/main-with-handlers (cmd)
(handler-case (handler-case
(cli/main cmd) (cli/main cmd)
@ -826,7 +834,7 @@ response to whoever needs to catch it. For example,
[[response-quit?]] is used by [[main-loop]] to identify when the user [[response-quit?]] is used by [[main-loop]] to identify when the user
has issued {\tt QUIT}, in which case we terminate [[main-loop]]. has issued {\tt QUIT}, in which case we terminate [[main-loop]].
<<Dispatching of commands>>= <<Dispatching of commands.lisp>>=
(defun dispatch (r) (defun dispatch (r)
(let* ((verb (request-verb r))) (let* ((verb (request-verb r)))
(if (null verb) (if (null verb)
@ -857,11 +865,11 @@ I should've called the member [[headers]] as [[head]] and not
suggest a list of parsed headers. We're going to rename this in due suggest a list of parsed headers. We're going to rename this in due
time. %% TODO time. %% TODO
<<Representation of articles>>= <<Representation of articles.lisp>>=
(defstruct article headers body) (defstruct article headers body)
@ @
<<How to parse articles>>= <<How to parse articles.lisp>>=
(defun parse-article (v) (defun parse-article (v)
(let ((parts (split-vector (vector 13 10 13 10) v nil :limit 2))) (let ((parts (split-vector (vector 13 10 13 10) v nil :limit 2)))
(make-article :headers (map 'string #'code-char (car parts)) :body (cadr parts)))) (make-article :headers (map 'string #'code-char (car parts)) :body (cadr parts))))
@ -894,7 +902,7 @@ time. %% TODO
We now write some procedures that we use when we're build the {\em We now write some procedures that we use when we're build the {\em
overview} of the command \verb|XOVER|. overview} of the command \verb|XOVER|.
<<How to parse articles>>= <<How to parse articles.lisp>>=
(defun get-header-from-article (h a) (defun get-header-from-article (h a)
(get-header h (parse-headers (article-headers (parse-article a))))) (get-header h (parse-headers (article-headers (parse-article a)))))
@ -923,7 +931,7 @@ We just read the article bytes and handle them to the client. It's
the article viewer's---the NNTP client's, that is---responsibility of the article viewer's---the NNTP client's, that is---responsibility of
interpreting such bytes. That's why we call [[read-sequence]] here. interpreting such bytes. That's why we call [[read-sequence]] here.
<<How to parse articles>>= <<How to parse articles.lisp>>=
(defun fetch-article (g i) (defun fetch-article (g i)
(in-groups (in-groups
(read-file-raw (format nil "~a/~a" g i)))) (read-file-raw (format nil "~a/~a" g i))))
@ -949,7 +957,7 @@ article. Since ``\verb|.\r\n|'' is part of the NNTP protocol, we must
handle this gracefully---but notice we have not done anything about handle this gracefully---but notice we have not done anything about
that so far. So we are essentially writing a bug right here. that so far. So we are essentially writing a bug right here.
<<How to parse articles>>= <<How to parse articles.lisp>>=
(defun encode-body (a) a) (defun encode-body (a) a)
@ %def encode-body @ %def encode-body
@ -959,7 +967,7 @@ merge with [[extract-mid]]. I think I also wrote more
redundancies---perhaps in the implementatio nof [[xover]]---for not redundancies---perhaps in the implementatio nof [[xover]]---for not
using [[lookup]]. I need to seek out all such places and organize. %% TODO using [[lookup]]. I need to seek out all such places and organize. %% TODO
<<How to parse articles>>= <<How to parse articles.lisp>>=
(defun extract-mid (a) (defun extract-mid (a)
(lookup "message-id" (parse-headers (article-headers (parse-article a))))) (lookup "message-id" (parse-headers (article-headers (parse-article a)))))
(defun lookup (key table) (defun lookup (key table)
@ -982,7 +990,7 @@ procedure at the REPL, but that's not so with [[labels]]. I guess the
use of [[labels]] is when the procedure is so trivial that we have no use of [[labels]] is when the procedure is so trivial that we have no
reason to think we're doing to debug it.} reason to think we're doing to debug it.}
<<Command help>>= <<Command help.lisp>>=
(defun cmd-help (r) (defun cmd-help (r)
(let ((lines (menu *commands-assoc*))) (let ((lines (menu *commands-assoc*)))
(prepend-response-with (prepend-response-with
@ -1017,7 +1025,7 @@ procedure [[pass?]] that's defined in the implementation of {\tt
Syntax error. Say ``authinfo USER /your-name/'' then ``authinfo PASS /your-pass/''. Syntax error. Say ``authinfo USER /your-name/'' then ``authinfo PASS /your-pass/''.
@ @
<<Command authinfo>>= <<Command authinfo.lisp>>=
(defun cmd-authinfo (r) (defun cmd-authinfo (r)
(let* ((args (mapcar #'str:upcase (request-args r)))) (let* ((args (mapcar #'str:upcase (request-args r))))
(cond (cond
@ -1072,11 +1080,10 @@ Same as in @<<Form of newsgroup names@>>. We'll let users create
whatever complicated user names they want. If they can type it up, whatever complicated user names they want. If they can type it up,
it's their problem. it's their problem.
<<Command create-account>>= <<Command create-account.lisp>>=
(defun user-name-conforms? (u) (defun user-name-conforms? (u)
(conforms-to? u "<<Form of user names>>")) (conforms-to? u "<<Form of user names>>"))
<<Command create-account>>=
(defun cmd-create-account (r) (defun cmd-create-account (r)
(with-auth (with-auth
(with-n-args 1 r (with-n-args 1 r
@ -1093,12 +1100,12 @@ it's their problem.
username pass-or-error))))))))) username pass-or-error)))))))))
@ @
<<Representation of accounts>>= <<Representation of accounts.lisp>>=
(defstruct account username seen last-post friends pass pass-locked pass-locked-why creation) (defstruct account username seen last-post friends pass pass-locked pass-locked-why creation)
(defparameter *accounts* nil) (defparameter *accounts* nil)
@ %def *accounts* @ %def *accounts*
<<Command create-account>>= <<Command create-account.lisp>>=
(defun read-accounts! () (defun read-accounts! ()
(let ((*package* (find-package '#:loop))) (let ((*package* (find-package '#:loop)))
(with-open-file (with-open-file
@ -1143,7 +1150,7 @@ locking or we do something smarter without a real file locking
mechanism. It's not clear to me what is possible here, but this is mechanism. It's not clear to me what is possible here, but this is
definitely a problem that we need to solve. definitely a problem that we need to solve.
<<Command create-account>>= <<Command create-account.lisp>>=
(defun write-accounts! () (defun write-accounts! ()
(let ((name (let ((name
(loop (loop
@ -1174,7 +1181,7 @@ Inactive accounts are removed or locked---see Section
\ref{sec:inactive-users}. When an account is locked, any member can \ref{sec:inactive-users}. When an account is locked, any member can
unlock it. unlock it.
<<Command create-account>>= <<Command create-account.lisp>>=
(defun cmd-unlock-account (r) (defun cmd-unlock-account (r)
(with-auth (with-auth
(with-n-args 1 r (with-n-args 1 r
@ -1211,7 +1218,7 @@ implement a more convenient command for authenticationwhen we interact
with \lp\ through a command-line interface. Instead of having to say with \lp\ through a command-line interface. Instead of having to say
two commands, we can just say {\tt login user password}. two commands, we can just say {\tt login user password}.
<<Command login>>= <<Command login.lisp>>=
(defun cmd-login (r) (defun cmd-login (r)
(let* ((args (mapcar #'str:upcase (request-args r)))) (let* ((args (mapcar #'str:upcase (request-args r))))
(cond (cond
@ -1238,7 +1245,7 @@ A change of password is made with {\tt PASSWD current new}. Observe
that we are duplicating code from other command procedures. I think that we are duplicating code from other command procedures. I think
there is a macro emerging here called [[with-upcase-args]]. %% TODO there is a macro emerging here called [[with-upcase-args]]. %% TODO
<<Command passwd>>= <<Command passwd.lisp>>=
(defun cmd-passwd (r) (defun cmd-passwd (r)
(with-auth (with-auth
(let* ((args (mapcar #'str:upcase (request-args r)))) (let* ((args (mapcar #'str:upcase (request-args r))))
@ -1283,7 +1290,7 @@ there is a macro emerging here called [[with-upcase-args]]. %% TODO
The tree of users and their friends is public. Anyone can know who The tree of users and their friends is public. Anyone can know who
invited who. invited who.
<<Command users>>= <<Command users.lisp>>=
(defun cmd-list-users (r) (defun cmd-list-users (r)
(with-auth (with-auth
(prepend-response-with (prepend-response-with
@ -1337,7 +1344,7 @@ 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 information in a file that is read at start-up. I think we should
even cache the overview of the group.) %% TODO even cache the overview of the group.) %% TODO
<<Command list>>= <<Command list.lisp>>=
(defstruct group name high low) (defstruct group name high low)
(defun cmd-list (r) (defun cmd-list (r)
@ -1379,7 +1386,7 @@ even cache the overview of the group.) %% TODO
(defun article-ready? (path) (defun article-ready? (path)
(not (temporary-article? path))) (not (temporary-article? path)))
<<Workaround for list-directories and list-files>> <<Workaround for list-directories and list-files.lisp>>
(defun get-articles (g &optional from to) (defun get-articles (g &optional from to)
(in-groups ;; We might want to optimize this some day. That's a (in-groups ;; We might want to optimize this some day. That's a
@ -1417,7 +1424,7 @@ In [[basename]], what we want to do is---if the path ends with a
slash, we invoke [[pathname]]. Otherwise, we invoke {\tt slash, we invoke [[pathname]]. Otherwise, we invoke {\tt
file-namestring}. file-namestring}.
<<Command list>>= <<Command list.lisp>>=
(defun basename (path) (defun basename (path)
(let ((s (str:collapse-whitespaces path))) (let ((s (str:collapse-whitespaces path)))
(if (char= #\/ (last-char s)) (if (char= #\/ (last-char s))
@ -1438,7 +1445,7 @@ To list directories and files, I have been using
procedures below using the chunk [[#-cffi]] to get \Lp\ working procedures below using the chunk [[#-cffi]] to get \Lp\ working
on these systems. on these systems.
<<Workaround for list-directories and list-files>>= <<Workaround for list-directories and list-files.lisp>>=
(defun loop-directory* (directory &rest args &key &allow-other-keys) (defun loop-directory* (directory &rest args &key &allow-other-keys)
#+allegro (apply #'directory directory :directories-are-files NIL :follow-symbolic-links NIL args) #+allegro (apply #'directory directory :directories-are-files NIL :follow-symbolic-links NIL args)
#+(or clozure digitool) (apply #'directory directory :follow-links NIL args) #+(or clozure digitool) (apply #'directory directory :follow-links NIL args)
@ -1484,7 +1491,7 @@ To list directories and files, I have been using
We just need to verify if the group exists and modify [[*client*]]. We just need to verify if the group exists and modify [[*client*]].
<<Command group>>= <<Command group.lisp>>=
(defun cmd-group (r) (defun cmd-group (r)
(with-auth (with-auth
(with-n-args 1 r (with-n-args 1 r
@ -1523,7 +1530,7 @@ specifies the article number. In case (3), the NNTP client specifies
the exact {\tt message-id}, which forces us to query the index---see the exact {\tt message-id}, which forces us to query the index---see
Section~\ref{sec:index} for the implementation of the index. Section~\ref{sec:index} for the implementation of the index.
<<Commands head, body, article>>= <<Commands head, body, article.lisp>>=
(defun typical-cmd-head-body-article (r fn-name) (defun typical-cmd-head-body-article (r fn-name)
(with-auth (with-auth
(with-group-set (with-group-set
@ -1565,21 +1572,16 @@ must provide the size when producing the \verb|OVERVIEW|. If a
problem such as [[sb-posix:syscall-error]] appears, we just inform the problem such as [[sb-posix:syscall-error]] appears, we just inform the
client and terminate the request---nothing else to do. client and terminate the request---nothing else to do.
XXX: instead of only catching [[sb-posix:syscall-error]], we should Our error checking strategy below is the following. If the user
catch anything else, reporting the error. Otherwise, we will blow up requests an article we don't have, we figure it out with
in case of some unexpected error, which might not be a bad idea---as [[fetch-article]]. If a system error come up such as a failed system
long as we can log these errors and get a report later on of what's call, we report it to the user and log it---there's probably nothing
going on so we can improve the code. I still don't really know what else we can do. The same is the case for all other errors. What I
to do here. Let's leave it as it is. The original idea is to put a want to do is to log it. What's important is that we seem to have
[[t]]-case in the [[handler-case]] below and just log the error enough code to treat any future case we might want to add and we're
instead of crashing completely. We can simulate the catching of an not ignoring any errors at all.
unexpected condition by signaling it from fetch-article as a test.
This type of situation should have a testing routine as well. So,
yeah, first give yourself another read of the [[lisp-unit]]
documentation, then how to handle conditions properly and then come
back to this to-do item.
<<Commands head, body, article>>= <<Commands head, body, article.lisp>>=
(defun typical-cmd-response (code r g i get-data) (defun typical-cmd-response (code r g i get-data)
(handler-case (handler-case
(let ((a (fetch-article g i))) (let ((a (fetch-article g i)))
@ -1593,14 +1595,21 @@ back to this to-do item.
(make-response :multi-line 'yes :code code (make-response :multi-line 'yes :code code
:request r :data (funcall get-data a)))))) :request r :data (funcall get-data a))))))
(sb-posix:syscall-error (c) (sb-posix:syscall-error (c)
(make-response (let ((msg (format nil "article ~a/~a: ~a" g i c)))
:code 400 :request r (stderr msg)
:data (format nil "article ~a/~a: ~a" g i c))))) (make-response
:code 400 :request r :data msg)))
(error (c)
(let ((msg (format nil "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 @ %def typical-cmd-response
The command \verb|NEXT| has a slight different semantics. The command \verb|NEXT| has a slight different semantics.
<<Commands head, body, article>>= <<Commands head, body, article.lisp>>=
(defun cmd-next (r) (defun cmd-next (r)
(with-auth (with-auth
(let ((g (client-group *client*)) (let ((g (client-group *client*))
@ -1631,7 +1640,7 @@ work. Notice that when the argument [[to]] from [[xover]] is [[NIL]],
then the user is asking for articles indexed from the integer [[fr]] then the user is asking for articles indexed from the integer [[fr]]
to the last one. to the last one.
<<Command xover>>= <<Command xover.lisp>>=
(defun cmd-xover (r) (defun cmd-xover (r)
(with-auth (with-auth
(with-group-set (with-group-set
@ -1685,7 +1694,7 @@ to the last one.
So, we're always in reader mode, so we just ignore this command. So, we're always in reader mode, so we just ignore this command.
<<Command mode reader>>= <<Command mode reader.lisp>>=
(defun cmd-mode (r) ;; Whatever. (defun cmd-mode (r) ;; Whatever.
(make-response :code 200 :request r :data "Sure thing.")) (make-response :code 200 :request r :data "Sure thing."))
@ %def @ %def
@ -1695,7 +1704,7 @@ So, we're always in reader mode, so we just ignore this command.
It's always useful to know the time and date at a computer. We should It's always useful to know the time and date at a computer. We should
surely format it a bit better than what {\tt now} does. surely format it a bit better than what {\tt now} does.
<<Command date>>= <<Command date.lisp>>=
(defun cmd-date (r) (defun cmd-date (r)
(make-response :code 201 (make-response :code 201
:request r :request r
@ -1708,7 +1717,7 @@ surely format it a bit better than what {\tt now} does.
The use of {\tt QUIT} has a conection to [[main-loop]]: when the user The use of {\tt QUIT} has a conection to [[main-loop]]: when the user
says {\tt QUIT}, [[main-loop]] must terminate. says {\tt QUIT}, [[main-loop]] must terminate.
<<Command quit>>= <<Command quit.lisp>>=
(defun cmd-quit (r) (defun cmd-quit (r)
(make-response :code 205 :data "Good-bye." :request r)) (make-response :code 205 :data "Good-bye." :request r))
@ %def @ %def
@ -1720,7 +1729,7 @@ shows to the client the internal state of how the server sees it.
I've used only for debugging and it's not really useful any longer. I've used only for debugging and it's not really useful any longer.
I'm going to remove this very soon. I'm going to remove this very soon.
<<Command dd>>= <<Command dd.lisp>>=
(defun cmd-dd (r) (defun cmd-dd (r)
(make-response :code 200 :data (format nil "state: ~a" *client*) :request r)) (make-response :code 200 :data (format nil "state: ~a" *client*) :request r))
@ %def @ %def
@ -1735,8 +1744,8 @@ must have \verb|message-id|, \verb|subject|, \verb|from|,
\verb|newsgroups|. If the client doesn't provide us with a \verb|newsgroups|. If the client doesn't provide us with a
\verb|message-id|, then \lp\ adds one. (Similarly for \verb|date|.) \verb|message-id|, then \lp\ adds one. (Similarly for \verb|date|.)
<<Command post>>= <<Command post.lisp>>=
<<Does an article conform?>> <<Does an article conform?.lisp>>
(defun suggest-message-id (&optional (n 20)) (defun suggest-message-id (&optional (n 20))
(format nil "<~a@loop>" (random-string n))) (format nil "<~a@loop>" (random-string n)))
@ -1753,7 +1762,7 @@ must have \verb|message-id|, \verb|subject|, \verb|from|,
Sometimes we parse an article and sometimes we want to undo that Sometimes we parse an article and sometimes we want to undo that
parsing. Am I doing something wrong? I wonder. parsing. Am I doing something wrong? I wonder.
<<Command post>>= <<Command post.lisp>>=
(defun unparse-article (parsed) (defun unparse-article (parsed)
(data (data
(let ((ls)) (let ((ls))
@ -1770,7 +1779,7 @@ If an article being posted has no \verb|message-id| or \verb|date|,
procedures that would generate such headers if they're missing. Right procedures that would generate such headers if they're missing. Right
now, however, we have only these two to worry about. now, however, we have only these two to worry about.
<<Command post>>= <<Command post.lisp>>=
(defun ensure-header (h fn bs) (defun ensure-header (h fn bs)
(let* ((headers (parse-headers (article-headers (parse-article bs))))) (let* ((headers (parse-headers (article-headers (parse-article bs)))))
(if (lookup h headers) (if (lookup h headers)
@ -1820,7 +1829,7 @@ 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 the matter and find a solution. Let's let people mess it up instead
of trying to stop them. of trying to stop them.
<<Command post>>= <<Command post.lisp>>=
(defun cmd-post (r) (defun cmd-post (r)
(with-auth (with-auth
(send-response! (send-response!
@ -1854,7 +1863,7 @@ 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 refuse posting and return a 400 code with a message describing which
group names failed. Otherwise we save the article. group names failed. Otherwise we save the article.
<<Command post>>= <<Command post.lisp>>=
(defun post (bs) (defun post (bs)
(let ((ngs (newsgroups-header->list (let ((ngs (newsgroups-header->list
(get-header "newsgroups" (parse-headers (get-header "newsgroups" (parse-headers
@ -1891,7 +1900,7 @@ and saves the article more easily. That's a better idea. I think
username to which to update the last-seen date should be included in username to which to update the last-seen date should be included in
the data structure. the data structure.
<<Command post>>= <<Command post.lisp>>=
(defun update-last-post-date! (username) (defun update-last-post-date! (username)
(let ((u (get-account username))) (let ((u (get-account username)))
(setf (account-last-post u) (get-universal-time)))) (setf (account-last-post u) (get-universal-time))))
@ -1909,7 +1918,7 @@ target might be okay, but that's not allowed on Windows systems. Even
though we have no interest in running \Lp\ on Windows, closing before though we have no interest in running \Lp\ on Windows, closing before
renaming it sounds more like the Right Thing to do. renaming it sounds more like the Right Thing to do.
<<Command post>>= <<Command post.lisp>>=
(defun rename-no-extension (old new) (defun rename-no-extension (old new)
(rename-file old (make-pathname :name new :type :unspecific))) (rename-file old (make-pathname :name new :type :unspecific)))
@ -1940,7 +1949,7 @@ The procedure [[save-article-insist]] insists on calling
allocated. Notice that the argument [[name]] is an integer, so allocated. Notice that the argument [[name]] is an integer, so
[[name]] is incremented at each iteration. [[name]] is incremented at each iteration.
<<Command post>>= <<Command post.lisp>>=
(defun save-article-insist (g name a message-id) (defun save-article-insist (g name a message-id)
(loop for name from name do (loop for name from name do
(in-dir (format nil "groups/~a/" g) (in-dir (format nil "groups/~a/" g)
@ -1962,7 +1971,7 @@ is. This is important to speed up posting. For instance, if we allow
attachments (which we don't), the performance penalty is clearly attachments (which we don't), the performance penalty is clearly
noticeable. %%TODO noticeable. %%TODO
<<Command post>>= <<Command post.lisp>>=
(defun nntp-read-article (&optional acc) (defun nntp-read-article (&optional acc)
;; Returns List-of Byte. ;; Returns List-of Byte.
(let* ((ls (ucs-2->ascii (nntp-read-line)))) (let* ((ls (ucs-2->ascii (nntp-read-line))))
@ -1981,7 +1990,7 @@ because sometimes the list [[acc]] comes out empty, but an empty line
never comes from the NNTP protocol because there's is always a {\tt never comes from the NNTP protocol because there's is always a {\tt
CR} before {\tt LF}. CR} before {\tt LF}.
<<Command post>>= <<Command post.lisp>>=
(defun nntp-read-line (&optional (s *standard-input*) acc) (defun nntp-read-line (&optional (s *standard-input*) acc)
;; Returns List-of Byte. ;; Returns List-of Byte.
(let ((x (read-byte s))) (let ((x (read-byte s)))
@ -2033,7 +2042,7 @@ does. I need to review this and then add the explanation for myself.
If I don't remember how this works, other beginners won't know it If I don't remember how this works, other beginners won't know it
either. %% TODO either. %% TODO
<<Does an article conform?>>= <<Does an article conform?.lisp>>=
(defun conforms? (bs) (defun conforms? (bs)
(catch 'article-syntax-error ;; parse-headers might throw (catch 'article-syntax-error ;; parse-headers might throw
(let ((headers (parse-headers (article-headers (parse-article bs))))) (let ((headers (parse-headers (article-headers (parse-article bs)))))
@ -2090,7 +2099,7 @@ 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 assume that when someone creates a group, it's either no problem at
all or it has been discussed with the community beforehand. all or it has been discussed with the community beforehand.
<<Command create-group>>= <<Command create-group.lisp>>=
(defun cmd-create-group (r) (defun cmd-create-group (r)
(with-n-args 1 r (with-n-args 1 r
(let ((g (string-downcase (car (request-args r))))) (let ((g (string-downcase (car (request-args r)))))
@ -2123,7 +2132,7 @@ all or it has been discussed with the community beforehand.
\lp\ is totally {\em hackable}. Users can say {\tt repl} to have \lp\ is totally {\em hackable}. Users can say {\tt repl} to have
complete control over their \lxxp\ process. complete control over their \lxxp\ process.
<<Command repl>>= <<Command repl.lisp>>=
(defun cmd-repl (r) (defun cmd-repl (r)
(if *enable-nntp-repl* (if *enable-nntp-repl*
(with-auth (with-auth
@ -2141,7 +2150,7 @@ to \lp\ because this way users are advertised about the commands that
exist---they could be having fun, but their sysadmin doesn't think exist---they could be having fun, but their sysadmin doesn't think
they're skilled enough. they're skilled enough.
<<Global variable that decides whether to enable the NNTP REPL>>= <<Global variable that decides whether to enable the NNTP REPL.lisp>>=
(defparameter *enable-nntp-repl* t) (defparameter *enable-nntp-repl* t)
@ @
@ -2151,7 +2160,7 @@ If you're interested in being notified about what's going on in the
\lp, then subscribe to {\tt local.control.news}. Group creation, \lp, then subscribe to {\tt local.control.news}. Group creation,
invitations {\em et cetera} are published there. invitations {\em et cetera} are published there.
<<Broadcasting>>= <<Broadcasting.lisp>>=
(defun notify-group-created (g) (defun notify-group-created (g)
(post-notification (post-notification
:subject (fmt "new group ~a by ~a" g (client-username *client*)) :subject (fmt "new group ~a by ~a" g (client-username *client*))
@ -2196,7 +2205,7 @@ When we find this line termination, we have its position in the
consumed list. With the position, we collect the line and we iterate consumed list. With the position, we collect the line and we iterate
searching for the next line. searching for the next line.
<<How to split a stream into lines>>= <<How to split a stream into lines.lisp>>=
(defun split-vector (delim v acc &key limit (so-far 1)) (defun split-vector (delim v acc &key limit (so-far 1))
(let ((len (length v))) (let ((len (length v)))
(split-vector-helper delim v len acc limit so-far 0))) (split-vector-helper delim v len acc limit so-far 0)))
@ -2253,11 +2262,11 @@ convenient for us: we don't need to specify with which database we're
working. Since we work with only one, we pretty much never need to working. Since we work with only one, we pretty much never need to
specify anything. specify anything.
<<Reference to the database>>= <<Reference to the database.lisp>>=
(defparameter *default-database* nil) (defparameter *default-database* nil)
@ %def *default-database* @ %def *default-database*
<<How to create and connect to the index>>= <<How to create and connect to the index.lisp>>=
(defun connect-index! (filename) (defun connect-index! (filename)
(setq *default-database* (clsql:connect (list filename) :database-type :sqlite3))) (setq *default-database* (clsql:connect (list filename) :database-type :sqlite3)))
@ -2333,7 +2342,7 @@ Sure---in the future, we will not duplicate articles in storage; we
will make symbolic links. We don't do that right now because Windows will make symbolic links. We don't do that right now because Windows
doesn't really support symbolic links. doesn't really support symbolic links.
<<Essential operations relative to the index>>= <<Essential operations relative to the index.lisp>>=
(defun insert-index (m g i) (defun insert-index (m g i)
(handler-case (handler-case
(clsql:insert-records (clsql:insert-records
@ -2382,7 +2391,7 @@ 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 the numeric ID of the article---and its {\tt message-id}. That's all
we need to index it. we need to index it.
<<How to create an index from the file system>>= <<How to create an index from the file system.lisp>>=
(defun index-from-fs! () (defun index-from-fs! ()
(loop for path in (in-groups (directory "**/*")) (loop for path in (in-groups (directory "**/*"))
do (let* ((g (str:trim (first (last (pathname-directory path))))) do (let* ((g (str:trim (first (last (pathname-directory path)))))
@ -2400,7 +2409,7 @@ we need to index it.
Here's a program to build the index from a UNIX shell. Here's a program to build the index from a UNIX shell.
<<build-index-from-fs.lisp>>= <<build-index-from-fs.lisp>>=
<<Quicklisp loading preamble>> <<Quicklisp loading preamble.lisp>>
(ql:quickload :loop :silent t) (ql:quickload :loop :silent t)
(in-package #:loop) (in-package #:loop)
(connect-index! "message-id.db") (connect-index! "message-id.db")
@ -2428,7 +2437,7 @@ Index built.
We now implement some of the \hyperref[principles]{principles} exposed We now implement some of the \hyperref[principles]{principles} exposed
earlier on page~\pageref{principles}. The program earlier on page~\pageref{principles}. The program
@<<cron-remove-inactive-users.lisp@>> would be run by {\tt cron} every @<<cron-remove-inactive-users.lisp@>> would be run by {\tt cron} every
day (at midnight, say). It checks all accounts that are inactive and day (at midnight, say). It checks all accounts that are inactive and
either locks them (to be deleted later) or deletes them {\em for either locks them (to be deleted later) or deletes them {\em for
good}. If you want to keep accounts forever, just don't run the good}. If you want to keep accounts forever, just don't run the
@ -2437,7 +2446,7 @@ that are locked (by the same period of time), but we have not yet done
that. that.
<<cron-remove-inactive-users.lisp>>= <<cron-remove-inactive-users.lisp>>=
<<Quicklisp loading preamble>> <<Quicklisp loading preamble.lisp>>
(ql:quickload :loop :silent t) (ql:quickload :loop :silent t)
(in-package #:loop) (in-package #:loop)
(read-accounts!) (read-accounts!)
@ -2448,7 +2457,7 @@ that.
The entire program is really [[remove-inactive-users!]]. The entire program is really [[remove-inactive-users!]].
<<How to remove inactive users>>= <<How to remove inactive users.lisp>>=
(defun remove-inactive-users! () (defun remove-inactive-users! ()
(loop for u in *accounts* do (loop for u in *accounts* do
(let ((username (account-username u))) (let ((username (account-username u)))
@ -2484,7 +2493,7 @@ take effect---for example, when deleting the first element of a list.
lists are implemented in C, say, then you're likely well aware of how lists are implemented in C, say, then you're likely well aware of how
it works.) it works.)
<<How to remove inactive users>>= <<How to remove inactive users.lisp>>=
(defun remove-account! (username) (defun remove-account! (username)
(loop for u in *accounts* do (loop for u in *accounts* do
(setf (account-friends u) (setf (account-friends u)
@ -2508,7 +2517,7 @@ 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 not remove this set of source code chunks because they serve as an
example of how to a migration like that.) example of how to a migration like that.)
<<How to migrate accounts without a creation date>>= <<How to migrate accounts without a creation date.lisp>>=
(defun loop-epoch () (defun loop-epoch ()
(encode-timestamp 0 0 0 0 1 1 2024)) (encode-timestamp 0 0 0 0 1 1 2024))
@ -2524,7 +2533,7 @@ example of how to a migration like that.)
Here's a program to run the migration in a UNIX shell. Here's a program to run the migration in a UNIX shell.
<<migrate-add-creation-date.lisp>>= <<migrate-add-creation-date.lisp>>=
<<Quicklisp loading preamble>> <<Quicklisp loading preamble.lisp>>
(ql:quickload :loop :silent t) (ql:quickload :loop :silent t)
(in-package #:loop) (in-package #:loop)
(migrate-add-creation-and-post-date!) (migrate-add-creation-and-post-date!)
@ -2533,12 +2542,12 @@ Here's a program to run the migration in a UNIX shell.
Now we write the procedures that discover what accounts are inactive. Now we write the procedures that discover what accounts are inactive.
<<Definition of maximum allowed inactive periods>>= <<Definition of maximum allowed inactive periods.lisp>>=
(defparameter *months-inactive-allowed* 3) (defparameter *months-inactive-allowed* 3)
(defparameter *months-never-logged-in* 1) (defparameter *months-never-logged-in* 1)
@ @
<<How to enumerate inactive accounts>>= <<How to enumerate inactive accounts.lisp>>=
(defun user-inactive? (username) (defun user-inactive? (username)
(or (inactive-from-never-logged-in? username) (or (inactive-from-never-logged-in? username)
(inactive-from-last-seen? username))) (inactive-from-last-seen? username)))
@ -2598,7 +2607,7 @@ example, when we need to access the group database, we use
[[in-groups]]. When a certain command demands authentication, we use [[in-groups]]. When a certain command demands authentication, we use
[[with-auth]]. [[with-auth]].
<<Macros>>= <<Macros.lisp>>=
(defmacro in-dir (dir &rest body) (defmacro in-dir (dir &rest body)
`(let ((*default-pathname-defaults* (truename ,dir))) `(let ((*default-pathname-defaults* (truename ,dir)))
(uiop:with-current-directory (,dir) (uiop:with-current-directory (,dir)
@ -2612,7 +2621,7 @@ 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 used to invoke [[renameat2]] through the [[cffi]], but we don't use it
any more. any more.
<<Macros>>= <<Macros.lisp>>=
(defmacro in-groups (&rest body) `(in-dir "groups/" ,@body)) (defmacro in-groups (&rest body) `(in-dir "groups/" ,@body))
(defun in-group-lambda (g fn) (in-dir g (funcall fn))) (defun in-group-lambda (g fn) (in-dir g (funcall fn)))
@ -2664,7 +2673,7 @@ of UCS-2. Despite the name UCS-2, notice it is UTF-16. The name UCS
stands for ``Universal Character Set'' and I speculate the number 2 stands for ``Universal Character Set'' and I speculate the number 2
means 2 bytes. So our conversion is just removing the first byte. means 2 bytes. So our conversion is just removing the first byte.
<<Little procedures>>= <<Little procedures.lisp>>=
(defun conforms-to? (s re &optional error-msg) (defun conforms-to? (s re &optional error-msg)
"Does string S conform to regular expression RE?" "Does string S conform to regular expression RE?"
(let ((okay? (cl-ppcre:scan-to-strings re s))) (let ((okay? (cl-ppcre:scan-to-strings re s)))
@ -2773,7 +2782,7 @@ directory in which \lp's tests will find the groups directory in
place. Making that happen is as simple as changing place. Making that happen is as simple as changing
[[*default-pathname-defaults*]]. [[*default-pathname-defaults*]].
<<Test procedures>>= <<Test procedures.lisp>>=
(setq lisp-unit:*print-failures* t) (setq lisp-unit:*print-failures* t)
(define-test dispatching (define-test dispatching
(assert-true (equalp (empty-response) (dispatch (make-request))))) (assert-true (equalp (empty-response) (dispatch (make-request)))))
@ -2823,7 +2832,7 @@ taking place---here in the REPL at least.
Just say {\tt make loop} to your shell. Just say {\tt make loop} to your shell.
<<build-exe.lisp>>= <<build-exe.lisp>>=
<<Quicklisp loading preamble>> <<Quicklisp loading preamble.lisp>>
(ql:quickload :loop) (ql:quickload :loop)
(sb-ext:save-lisp-and-die #P"loop" (sb-ext:save-lisp-and-die #P"loop"
:toplevel #'loop:main :toplevel #'loop:main
@ -2831,7 +2840,7 @@ Just say {\tt make loop} to your shell.
:save-runtime-options t) :save-runtime-options t)
@ @
<<Quicklisp loading preamble>>= <<Quicklisp loading preamble.lisp>>=
#-quicklisp #-quicklisp
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" (let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
(user-homedir-pathname)))) (user-homedir-pathname))))
@ -2895,7 +2904,7 @@ something to think about.
;;; -*- mode: LISP; syntax: COMMON-LISP; package: LOOP; -*- ;;; -*- mode: LISP; syntax: COMMON-LISP; package: LOOP; -*-
(eval-when (:compile-toplevel :load-toplevel :execute) (eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload (ql:quickload
'(<<List of packages to be loaded>>) '(<<List of packages to be loaded.lisp>>)
:silent t)) :silent t))
(clsql:file-enable-sql-reader-syntax) (clsql:file-enable-sql-reader-syntax)
@ -2910,59 +2919,59 @@ something to think about.
(in-package #:loop) (in-package #:loop)
<<Global variables>> <<Global variables.lisp>>
<<Table of commands>> <<Table of commands.lisp>>
<<Macros>> <<Macros.lisp>>
<<Little procedures>> <<Little procedures.lisp>>
<<Loop's REPL>> <<Loop's REPL.lisp>>
<<Procedures for requests and responses>> <<Procedures for requests and responses.lisp>>
<<Essential operations relative to the index>> <<Essential operations relative to the index.lisp>>
<<How to create and connect to the index>> <<How to create and connect to the index.lisp>>
<<How to remove inactive users>> <<How to remove inactive users.lisp>>
<<How to enumerate inactive accounts>> <<How to enumerate inactive accounts.lisp>>
<<How to migrate accounts without a creation date>> <<How to migrate accounts without a creation date.lisp>>
<<How to split a stream into lines>> <<How to split a stream into lines.lisp>>
<<How to create an index from the file system>> <<How to create an index from the file system.lisp>>
<<How to parse articles>> <<How to parse articles.lisp>>
<<Dispatching of commands>> <<Dispatching of commands.lisp>>
<<Command authinfo>> <<Command authinfo.lisp>>
<<Command mode reader>> <<Command mode reader.lisp>>
<<Commands head, body, article>> <<Commands head, body, article.lisp>>
<<Command xover>> <<Command xover.lisp>>
<<Command group>> <<Command group.lisp>>
<<Command list>> <<Command list.lisp>>
<<Command help>> <<Command help.lisp>>
<<Command quit>> <<Command quit.lisp>>
<<Command date>> <<Command date.lisp>>
<<Command post>> <<Command post.lisp>>
<<Command create-group>> <<Command create-group.lisp>>
<<Command create-account>> <<Command create-account.lisp>>
<<Command login>> <<Command login.lisp>>
<<Command passwd>> <<Command passwd.lisp>>
<<Command users>> <<Command users.lisp>>
<<Command dd>> <<Command dd.lisp>>
<<Command repl>> <<Command repl.lisp>>
<<Broadcasting>> <<Broadcasting.lisp>>
<<Command-line parsing>> <<Command-line parsing.lisp>>
<<Main loop>> <<Main loop.lisp>>
<<Test procedures>> <<Test procedures.lisp>>
@ %def @ %def
<<Global variables>>= <<Global variables.lisp>>=
(defparameter *debug* nil) (defparameter *debug* nil)
<<Representation of accounts>> <<Representation of accounts.lisp>>
<<Representation of a client>> <<Representation of a client.lisp>>
<<Representation of requests and responses>> <<Representation of requests and responses.lisp>>
<<Reference to the database>> <<Reference to the database.lisp>>
<<Representation of commands>> <<Representation of commands.lisp>>
<<Representation of articles>> <<Representation of articles.lisp>>
<<Definition of maximum allowed inactive periods>> <<Definition of maximum allowed inactive periods.lisp>>
<<Global variable that decides whether to enable the NNTP REPL>> <<Global variable that decides whether to enable the NNTP REPL.lisp>>
@ @
On which packages do we depend? On which packages do we depend?
<<List of packages to be loaded>>= <<List of packages to be loaded.lisp>>=
:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon :lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon
:filesystem-utils :ironclad/digest/sha256 :filesystem-utils :ironclad/digest/sha256
@ @
@ -2974,7 +2983,7 @@ The \lp\ system definition:
(asdf:defsystem :<<Name>> (asdf:defsystem :<<Name>>
:version "<<Version>>" :version "<<Version>>"
:description "<<Description>>" :description "<<Description>>"
:depends-on (<<List of packages to be loaded>>) :depends-on (<<List of packages to be loaded.lisp>>)
:components ((:file "loop"))) :components ((:file "loop")))
@ @
@ -3005,7 +3014,7 @@ 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 {\tt D} command does. This strategy is explained by Dale Dougherty
and Arnold Robbins in ``sed \& awk'' second edition, pages 112--114. and Arnold Robbins in ``sed \& awk'' second edition, pages 112--114.
<<format-def>>= <<format-def.sh>>=
#!/bin/sh #!/bin/sh
usage() usage()
{ {
@ -3040,7 +3049,7 @@ the body of the chunk @<<Version@>>. The {\tt sed} program is
straightforward: locate the chunk definition, move down a line, change straightforward: locate the chunk definition, move down a line, change
that line and that's all. that line and that's all.
<<make-release>>= <<make-release.sh>>=
#!/bin/sh #!/bin/sh
usage() usage()
{ {