Uses polymode in the GNU EMACS, not noweb-mode any longer.
This commit is contained in:
parent
4412496fb6
commit
efa5ee3ccd
3 changed files with 239 additions and 220 deletions
40
Anyfile
40
Anyfile
|
|
@ -6,27 +6,28 @@ default: all
|
|||
all: loop.exe loop.lisp loop.asd scripts/build-exe.lisp \
|
||||
scripts/build-index-from-fs.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
|
||||
sbcl --script scripts/build-exe.lisp
|
||||
(test -f loop.exe && cmp loop loop.exe) || cp loop loop.exe
|
||||
|
||||
loop.lisp: loop.nw format-def
|
||||
(any tangle -Rloop.lisp < loop.nw | sh format-def | \
|
||||
dos2unix > loop.tmp || \
|
||||
(no tangle -Rloop.lisp < loop.nw | sh format-def > loop.tmp || \
|
||||
(rm loop.tmp && exit 1)) && \
|
||||
mv loop.tmp loop.lisp
|
||||
|
||||
format-def: loop.nw
|
||||
(any tangle -Rformat-def < loop.nw | \
|
||||
dos2unix > format-def.tmp || \
|
||||
(no tangle -Rformat-def.sh < loop.nw > format-def.tmp || \
|
||||
(rm format-def.tmp && exit 1)) && \
|
||||
mv format-def.tmp format-def
|
||||
|
||||
make-release: loop.nw
|
||||
(any tangle -Rmake-release < loop.nw | \
|
||||
dos2unix > make-release.tmp || \
|
||||
(no tangle -Rmake-release.sh < loop.nw > make-release.tmp || \
|
||||
(rm make-release.tmp && exit 1)) && \
|
||||
mv make-release.tmp make-release
|
||||
|
||||
|
|
@ -35,47 +36,48 @@ release: make-release
|
|||
loop.nw > loop.tmp && mv loop.tmp 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)) && \
|
||||
mv loop-asd.tmp loop.asd
|
||||
|
||||
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)) && \
|
||||
mv build-exe.tmp scripts/build-exe.lisp
|
||||
|
||||
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 || \
|
||||
(rm build-index-from-fs.tmp && exit 1)) && \
|
||||
mv build-index-from-fs.tmp scripts/build-index-from-fs.lisp
|
||||
|
||||
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 || \
|
||||
(rm cron-remove-inactive-users.tmp && exit 1)) && \
|
||||
mv cron-remove-inactive-users.tmp \
|
||||
scripts/cron-remove-inactive-users.lisp
|
||||
|
||||
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 || \
|
||||
(rm migrate-add-creation-date.tmp && exit 1)) && \
|
||||
mv migrate-add-creation-date.tmp \
|
||||
scripts/migrate-add-creation-date.lisp
|
||||
|
||||
run: loop.nw
|
||||
(any tangle -Rrun < loop.nw | dos2unix > run.tmp || \
|
||||
(rm run.tmp && exit 1)) && \
|
||||
mv run.tmp run && \
|
||||
chmod 0755 run
|
||||
# run: loop.nw
|
||||
# (no tangle -Rrun < loop.nw > run.tmp || \
|
||||
# (rm run.tmp && exit 1)) && \
|
||||
# mv run.tmp run && \
|
||||
# chmod 0755 run
|
||||
|
||||
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
|
||||
latexmk -pdf loop
|
||||
|
||||
clean:
|
||||
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
48
loop.lisp
|
|
@ -620,9 +620,16 @@
|
|||
(make-response :multi-line 'yes :code code
|
||||
:request r :data (funcall get-data a))))))
|
||||
(sb-posix:syscall-error (c)
|
||||
(make-response
|
||||
:code 400 :request r
|
||||
:data (format nil "article ~a/~a: ~a" g i c)))))
|
||||
(let ((msg (format nil "article ~a/~a: ~a" g i c)))
|
||||
(stderr msg)
|
||||
(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)
|
||||
(with-auth
|
||||
|
|
@ -1251,23 +1258,24 @@
|
|||
maximizing (length (account-username u))))
|
||||
|
||||
(defun list-users ()
|
||||
(read-accounts!)
|
||||
(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)))))
|
||||
(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
|
||||
|
|
|
|||
371
loop.nw
371
loop.nw
|
|
@ -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}
|
||||
\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
|
||||
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 destinaries. So long as everyone replies to everyone,
|
||||
John, too, will start getting all the messages. If anyone violates
|
||||
this rule of replying to everyone involved, the loop is broken.
|
||||
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}
|
||||
|
|
@ -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
|
||||
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 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
|
||||
resends the message to all subscribers of the mailing list and, this
|
||||
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
|
||||
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 for UNIX to
|
||||
UNIX copy. It's both a protocol and a set of programs for copying
|
||||
files between UNIX systems. People begun exchanging messages by
|
||||
copying files between machines. The idea 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''.
|
||||
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
|
||||
|
|
@ -140,7 +144,7 @@ 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.
|
||||
``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
|
||||
|
|
@ -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
|
||||
it will take asking another participant (with an active account) to do
|
||||
so. In other words, there's an encouragement for an uninterested
|
||||
member not to come back to the \lp. The idea is to keep a certain
|
||||
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 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
|
||||
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
|
||||
line, which is what causes that 400 response.
|
||||
|
||||
<<Loop's REPL>>=
|
||||
<<Loop's REPL.lisp>>=
|
||||
(defun repl (r)
|
||||
(in-package :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
|
||||
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))
|
||||
(defparameter *client* (make-client))
|
||||
@ %def client *client*
|
||||
|
||||
|
||||
\section{Representation of a command}
|
||||
|
||||
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|. For example, Gnus v5.13.)
|
||||
|
||||
<<Representation of commands>>=
|
||||
<<Representation of commands.lisp>>=
|
||||
(defstruct command fn verb description)
|
||||
(defparameter *commands-assoc* nil)
|
||||
@
|
||||
|
||||
<<Table of commands>>=
|
||||
<<Table of commands.lisp>>=
|
||||
(defun table-of-commands ()
|
||||
`(("GROUP" ,#'cmd-group "sets the current group")
|
||||
("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
|
||||
mark such responses with [[multi-line]].
|
||||
|
||||
<<Representation of requests and responses>>=
|
||||
<<Representation of requests and responses.lisp>>=
|
||||
(defstruct request verb args said)
|
||||
(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 prepend-response-with (message r)
|
||||
(make-response
|
||||
|
|
@ -546,7 +549,7 @@ mark such responses with [[multi-line]].
|
|||
|
||||
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)
|
||||
(cond
|
||||
((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
|
||||
else should we handle this?
|
||||
|
||||
<<Procedures for requests and responses>>=
|
||||
<<Procedures for requests and responses.lisp>>=
|
||||
(defun my-write (ls-of-bytes s)
|
||||
(if (interactive-stream-p 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]]
|
||||
itself---so we can cascade actions based on a user's request.
|
||||
|
||||
<<Main loop>>=
|
||||
<<Main loop.lisp>>=
|
||||
(defun main-loop ()
|
||||
(loop
|
||||
(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
|
||||
letters are equivalent in request verbs.
|
||||
|
||||
<<Procedures for requests and responses>>=
|
||||
<<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)))
|
||||
|
|
@ -686,11 +689,16 @@ letters are equivalent in request verbs.
|
|||
|
||||
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. XXX: notice I don't know how
|
||||
to support a two-argument option, so I hacked a solution away. What
|
||||
we need to is to implement a new option. The library is extensible.
|
||||
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 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 ()
|
||||
(list
|
||||
(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
|
||||
running a program [[./list-accounts]].
|
||||
|
||||
<<Command-line parsing>>=
|
||||
<<Command-line parsing.lisp>>=
|
||||
(defun cli/list-accounts ()
|
||||
(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
|
||||
service starts with [[server-start]].
|
||||
|
||||
<<Command-line parsing>>=
|
||||
<<Command-line parsing.lisp>>=
|
||||
(defun cli/main-with-handlers (cmd)
|
||||
(handler-case
|
||||
(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
|
||||
has issued {\tt QUIT}, in which case we terminate [[main-loop]].
|
||||
|
||||
<<Dispatching of commands>>=
|
||||
<<Dispatching of commands.lisp>>=
|
||||
(defun dispatch (r)
|
||||
(let* ((verb (request-verb r)))
|
||||
(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
|
||||
time. %% TODO
|
||||
|
||||
<<Representation of articles>>=
|
||||
<<Representation of articles.lisp>>=
|
||||
(defstruct article headers body)
|
||||
@
|
||||
|
||||
<<How to parse articles>>=
|
||||
<<How to parse articles.lisp>>=
|
||||
(defun parse-article (v)
|
||||
(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))))
|
||||
|
|
@ -894,7 +902,7 @@ time. %% TODO
|
|||
We now write some procedures that we use when we're build the {\em
|
||||
overview} of the command \verb|XOVER|.
|
||||
|
||||
<<How to parse articles>>=
|
||||
<<How to parse articles.lisp>>=
|
||||
(defun get-header-from-article (h 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
|
||||
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)
|
||||
(in-groups
|
||||
(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
|
||||
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)
|
||||
@ %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
|
||||
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)
|
||||
(lookup "message-id" (parse-headers (article-headers (parse-article a)))))
|
||||
(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
|
||||
reason to think we're doing to debug it.}
|
||||
|
||||
<<Command help>>=
|
||||
<<Command help.lisp>>=
|
||||
(defun cmd-help (r)
|
||||
(let ((lines (menu *commands-assoc*)))
|
||||
(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/''.
|
||||
@
|
||||
|
||||
<<Command authinfo>>=
|
||||
<<Command authinfo.lisp>>=
|
||||
(defun cmd-authinfo (r)
|
||||
(let* ((args (mapcar #'str:upcase (request-args r))))
|
||||
(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,
|
||||
it's their problem.
|
||||
|
||||
<<Command create-account>>=
|
||||
<<Command create-account.lisp>>=
|
||||
(defun user-name-conforms? (u)
|
||||
(conforms-to? u "<<Form of user names>>"))
|
||||
|
||||
<<Command create-account>>=
|
||||
(defun cmd-create-account (r)
|
||||
(with-auth
|
||||
(with-n-args 1 r
|
||||
|
|
@ -1093,12 +1100,12 @@ it's their problem.
|
|||
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)
|
||||
(defparameter *accounts* nil)
|
||||
@ %def *accounts*
|
||||
|
||||
<<Command create-account>>=
|
||||
<<Command create-account.lisp>>=
|
||||
(defun read-accounts! ()
|
||||
(let ((*package* (find-package '#:loop)))
|
||||
(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
|
||||
definitely a problem that we need to solve.
|
||||
|
||||
<<Command create-account>>=
|
||||
<<Command create-account.lisp>>=
|
||||
(defun write-accounts! ()
|
||||
(let ((name
|
||||
(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
|
||||
unlock it.
|
||||
|
||||
<<Command create-account>>=
|
||||
<<Command create-account.lisp>>=
|
||||
(defun cmd-unlock-account (r)
|
||||
(with-auth
|
||||
(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
|
||||
two commands, we can just say {\tt login user password}.
|
||||
|
||||
<<Command login>>=
|
||||
<<Command login.lisp>>=
|
||||
(defun cmd-login (r)
|
||||
(let* ((args (mapcar #'str:upcase (request-args r))))
|
||||
(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
|
||||
there is a macro emerging here called [[with-upcase-args]]. %% TODO
|
||||
|
||||
<<Command passwd>>=
|
||||
<<Command passwd.lisp>>=
|
||||
(defun cmd-passwd (r)
|
||||
(with-auth
|
||||
(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
|
||||
invited who.
|
||||
|
||||
<<Command users>>=
|
||||
<<Command users.lisp>>=
|
||||
(defun cmd-list-users (r)
|
||||
(with-auth
|
||||
(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
|
||||
even cache the overview of the group.) %% TODO
|
||||
|
||||
<<Command list>>=
|
||||
<<Command list.lisp>>=
|
||||
(defstruct group name high low)
|
||||
|
||||
(defun cmd-list (r)
|
||||
|
|
@ -1379,7 +1386,7 @@ even cache the overview of the group.) %% TODO
|
|||
(defun article-ready? (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)
|
||||
(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
|
||||
file-namestring}.
|
||||
|
||||
<<Command list>>=
|
||||
<<Command list.lisp>>=
|
||||
(defun basename (path)
|
||||
(let ((s (str:collapse-whitespaces path)))
|
||||
(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
|
||||
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)
|
||||
#+allegro (apply #'directory directory :directories-are-files NIL :follow-symbolic-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*]].
|
||||
|
||||
<<Command group>>=
|
||||
<<Command group.lisp>>=
|
||||
(defun cmd-group (r)
|
||||
(with-auth
|
||||
(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
|
||||
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)
|
||||
(with-auth
|
||||
(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
|
||||
client and terminate the request---nothing else to do.
|
||||
|
||||
XXX: instead of only catching [[sb-posix:syscall-error]], we should
|
||||
catch anything else, reporting the error. Otherwise, we will blow up
|
||||
in case of some unexpected error, which might not be a bad idea---as
|
||||
long as we can log these errors and get a report later on of what's
|
||||
going on so we can improve the code. I still don't really know what
|
||||
to do here. Let's leave it as it is. The original idea is to put a
|
||||
[[t]]-case in the [[handler-case]] below and just log the error
|
||||
instead of crashing completely. We can simulate the catching of an
|
||||
unexpected condition by signaling it from fetch-article as a test.
|
||||
This type of situation should have a testing routine as well. So,
|
||||
yeah, first give yourself another read of the [[lisp-unit]]
|
||||
documentation, then how to handle conditions properly and then come
|
||||
back to this to-do item.
|
||||
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.
|
||||
|
||||
<<Commands head, body, article>>=
|
||||
<<Commands head, body, article.lisp>>=
|
||||
(defun typical-cmd-response (code r g i get-data)
|
||||
(handler-case
|
||||
(let ((a (fetch-article g i)))
|
||||
|
|
@ -1593,14 +1595,21 @@ back to this to-do item.
|
|||
(make-response :multi-line 'yes :code code
|
||||
:request r :data (funcall get-data a))))))
|
||||
(sb-posix:syscall-error (c)
|
||||
(make-response
|
||||
:code 400 :request r
|
||||
:data (format nil "article ~a/~a: ~a" g i c)))))
|
||||
(let ((msg (format nil "article ~a/~a: ~a" g i c)))
|
||||
(stderr msg)
|
||||
(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
|
||||
|
||||
The command \verb|NEXT| has a slight different semantics.
|
||||
|
||||
<<Commands head, body, article>>=
|
||||
<<Commands head, body, article.lisp>>=
|
||||
(defun cmd-next (r)
|
||||
(with-auth
|
||||
(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]]
|
||||
to the last one.
|
||||
|
||||
<<Command xover>>=
|
||||
<<Command xover.lisp>>=
|
||||
(defun cmd-xover (r)
|
||||
(with-auth
|
||||
(with-group-set
|
||||
|
|
@ -1685,7 +1694,7 @@ to the last one.
|
|||
|
||||
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.
|
||||
(make-response :code 200 :request r :data "Sure thing."))
|
||||
@ %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
|
||||
surely format it a bit better than what {\tt now} does.
|
||||
|
||||
<<Command date>>=
|
||||
<<Command date.lisp>>=
|
||||
(defun cmd-date (r)
|
||||
(make-response :code 201
|
||||
: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
|
||||
says {\tt QUIT}, [[main-loop]] must terminate.
|
||||
|
||||
<<Command quit>>=
|
||||
<<Command quit.lisp>>=
|
||||
(defun cmd-quit (r)
|
||||
(make-response :code 205 :data "Good-bye." :request r))
|
||||
@ %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'm going to remove this very soon.
|
||||
|
||||
<<Command dd>>=
|
||||
<<Command dd.lisp>>=
|
||||
(defun cmd-dd (r)
|
||||
(make-response :code 200 :data (format nil "state: ~a" *client*) :request r))
|
||||
@ %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|message-id|, then \lp\ adds one. (Similarly for \verb|date|.)
|
||||
|
||||
<<Command post>>=
|
||||
<<Does an article conform?>>
|
||||
<<Command post.lisp>>=
|
||||
<<Does an article conform?.lisp>>
|
||||
(defun suggest-message-id (&optional (n 20))
|
||||
(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
|
||||
parsing. Am I doing something wrong? I wonder.
|
||||
|
||||
<<Command post>>=
|
||||
<<Command post.lisp>>=
|
||||
(defun unparse-article (parsed)
|
||||
(data
|
||||
(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
|
||||
now, however, we have only these two to worry about.
|
||||
|
||||
<<Command post>>=
|
||||
<<Command post.lisp>>=
|
||||
(defun ensure-header (h fn bs)
|
||||
(let* ((headers (parse-headers (article-headers (parse-article bs)))))
|
||||
(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
|
||||
of trying to stop them.
|
||||
|
||||
<<Command post>>=
|
||||
<<Command post.lisp>>=
|
||||
(defun cmd-post (r)
|
||||
(with-auth
|
||||
(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
|
||||
group names failed. Otherwise we save the article.
|
||||
|
||||
<<Command post>>=
|
||||
<<Command post.lisp>>=
|
||||
(defun post (bs)
|
||||
(let ((ngs (newsgroups-header->list
|
||||
(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
|
||||
the data structure.
|
||||
|
||||
<<Command post>>=
|
||||
<<Command post.lisp>>=
|
||||
(defun update-last-post-date! (username)
|
||||
(let ((u (get-account username)))
|
||||
(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
|
||||
renaming it sounds more like the Right Thing to do.
|
||||
|
||||
<<Command post>>=
|
||||
<<Command post.lisp>>=
|
||||
(defun rename-no-extension (old new)
|
||||
(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
|
||||
[[name]] is incremented at each iteration.
|
||||
|
||||
<<Command post>>=
|
||||
<<Command post.lisp>>=
|
||||
(defun save-article-insist (g name a message-id)
|
||||
(loop for name from name do
|
||||
(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
|
||||
noticeable. %%TODO
|
||||
|
||||
<<Command post>>=
|
||||
<<Command post.lisp>>=
|
||||
(defun nntp-read-article (&optional acc)
|
||||
;; Returns List-of Byte.
|
||||
(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
|
||||
CR} before {\tt LF}.
|
||||
|
||||
<<Command post>>=
|
||||
<<Command post.lisp>>=
|
||||
(defun nntp-read-line (&optional (s *standard-input*) acc)
|
||||
;; Returns List-of Byte.
|
||||
(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
|
||||
either. %% TODO
|
||||
|
||||
<<Does an article conform?>>=
|
||||
<<Does an article conform?.lisp>>=
|
||||
(defun conforms? (bs)
|
||||
(catch 'article-syntax-error ;; parse-headers might throw
|
||||
(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
|
||||
all or it has been discussed with the community beforehand.
|
||||
|
||||
<<Command create-group>>=
|
||||
<<Command create-group.lisp>>=
|
||||
(defun cmd-create-group (r)
|
||||
(with-n-args 1 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
|
||||
complete control over their \lxxp\ process.
|
||||
|
||||
<<Command repl>>=
|
||||
<<Command repl.lisp>>=
|
||||
(defun cmd-repl (r)
|
||||
(if *enable-nntp-repl*
|
||||
(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
|
||||
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)
|
||||
@
|
||||
|
||||
|
|
@ -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,
|
||||
invitations {\em et cetera} are published there.
|
||||
|
||||
<<Broadcasting>>=
|
||||
<<Broadcasting.lisp>>=
|
||||
(defun notify-group-created (g)
|
||||
(post-notification
|
||||
: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
|
||||
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))
|
||||
(let ((len (length v)))
|
||||
(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
|
||||
specify anything.
|
||||
|
||||
<<Reference to the database>>=
|
||||
<<Reference to the database.lisp>>=
|
||||
(defparameter *default-database* nil)
|
||||
@ %def *default-database*
|
||||
|
||||
<<How to create and connect to the index>>=
|
||||
<<How to create and connect to the index.lisp>>=
|
||||
(defun connect-index! (filename)
|
||||
(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
|
||||
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)
|
||||
(handler-case
|
||||
(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
|
||||
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! ()
|
||||
(loop for path in (in-groups (directory "**/*"))
|
||||
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.
|
||||
|
||||
<<build-index-from-fs.lisp>>=
|
||||
<<Quicklisp loading preamble>>
|
||||
<<Quicklisp loading preamble.lisp>>
|
||||
(ql:quickload :loop :silent t)
|
||||
(in-package #:loop)
|
||||
(connect-index! "message-id.db")
|
||||
|
|
@ -2428,7 +2437,7 @@ Index built.
|
|||
|
||||
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
|
||||
@<<cron-remove-inactive-users.lisp@>> would be run by {\tt cron} every
|
||||
day (at midnight, say). It checks all accounts that are inactive and
|
||||
either locks them (to be deleted later) or deletes them {\em for
|
||||
good}. If you want to keep accounts forever, just don't run the
|
||||
|
|
@ -2437,7 +2446,7 @@ that are locked (by the same period of time), but we have not yet done
|
|||
that.
|
||||
|
||||
<<cron-remove-inactive-users.lisp>>=
|
||||
<<Quicklisp loading preamble>>
|
||||
<<Quicklisp loading preamble.lisp>>
|
||||
(ql:quickload :loop :silent t)
|
||||
(in-package #:loop)
|
||||
(read-accounts!)
|
||||
|
|
@ -2448,7 +2457,7 @@ that.
|
|||
|
||||
The entire program is really [[remove-inactive-users!]].
|
||||
|
||||
<<How to remove inactive users>>=
|
||||
<<How to remove inactive users.lisp>>=
|
||||
(defun remove-inactive-users! ()
|
||||
(loop for u in *accounts* do
|
||||
(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
|
||||
it works.)
|
||||
|
||||
<<How to remove inactive users>>=
|
||||
<<How to remove inactive users.lisp>>=
|
||||
(defun remove-account! (username)
|
||||
(loop for u in *accounts* do
|
||||
(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
|
||||
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 ()
|
||||
(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.
|
||||
|
||||
<<migrate-add-creation-date.lisp>>=
|
||||
<<Quicklisp loading preamble>>
|
||||
<<Quicklisp loading preamble.lisp>>
|
||||
(ql:quickload :loop :silent t)
|
||||
(in-package #:loop)
|
||||
(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.
|
||||
|
||||
<<Definition of maximum allowed inactive periods>>=
|
||||
<<Definition of maximum allowed inactive periods.lisp>>=
|
||||
(defparameter *months-inactive-allowed* 3)
|
||||
(defparameter *months-never-logged-in* 1)
|
||||
@
|
||||
|
||||
<<How to enumerate inactive accounts>>=
|
||||
<<How to enumerate inactive accounts.lisp>>=
|
||||
(defun user-inactive? (username)
|
||||
(or (inactive-from-never-logged-in? 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
|
||||
[[with-auth]].
|
||||
|
||||
<<Macros>>=
|
||||
<<Macros.lisp>>=
|
||||
(defmacro in-dir (dir &rest body)
|
||||
`(let ((*default-pathname-defaults* (truename ,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
|
||||
any more.
|
||||
|
||||
<<Macros>>=
|
||||
<<Macros.lisp>>=
|
||||
(defmacro in-groups (&rest body) `(in-dir "groups/" ,@body))
|
||||
|
||||
(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
|
||||
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)
|
||||
"Does string S conform to regular expression RE?"
|
||||
(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
|
||||
[[*default-pathname-defaults*]].
|
||||
|
||||
<<Test procedures>>=
|
||||
<<Test procedures.lisp>>=
|
||||
(setq lisp-unit:*print-failures* t)
|
||||
(define-test dispatching
|
||||
(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.
|
||||
|
||||
<<build-exe.lisp>>=
|
||||
<<Quicklisp loading preamble>>
|
||||
<<Quicklisp loading preamble.lisp>>
|
||||
(ql:quickload :loop)
|
||||
(sb-ext:save-lisp-and-die #P"loop"
|
||||
:toplevel #'loop:main
|
||||
|
|
@ -2831,7 +2840,7 @@ Just say {\tt make loop} to your shell.
|
|||
:save-runtime-options t)
|
||||
@
|
||||
|
||||
<<Quicklisp loading preamble>>=
|
||||
<<Quicklisp loading preamble.lisp>>=
|
||||
#-quicklisp
|
||||
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
|
||||
(user-homedir-pathname))))
|
||||
|
|
@ -2895,7 +2904,7 @@ something to think about.
|
|||
;;; -*- mode: LISP; syntax: COMMON-LISP; package: LOOP; -*-
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(ql:quickload
|
||||
'(<<List of packages to be loaded>>)
|
||||
'(<<List of packages to be loaded.lisp>>)
|
||||
:silent t))
|
||||
|
||||
(clsql:file-enable-sql-reader-syntax)
|
||||
|
|
@ -2910,59 +2919,59 @@ something to think about.
|
|||
|
||||
(in-package #:loop)
|
||||
|
||||
<<Global variables>>
|
||||
<<Table of commands>>
|
||||
<<Macros>>
|
||||
<<Little procedures>>
|
||||
<<Loop's REPL>>
|
||||
<<Procedures for requests and responses>>
|
||||
<<Essential operations relative to the index>>
|
||||
<<How to create and connect to the index>>
|
||||
<<How to remove inactive users>>
|
||||
<<How to enumerate inactive accounts>>
|
||||
<<How to migrate accounts without a creation date>>
|
||||
<<How to split a stream into lines>>
|
||||
<<How to create an index from the file system>>
|
||||
<<How to parse articles>>
|
||||
<<Dispatching of commands>>
|
||||
<<Command authinfo>>
|
||||
<<Command mode reader>>
|
||||
<<Commands head, body, article>>
|
||||
<<Command xover>>
|
||||
<<Command group>>
|
||||
<<Command list>>
|
||||
<<Command help>>
|
||||
<<Command quit>>
|
||||
<<Command date>>
|
||||
<<Command post>>
|
||||
<<Command create-group>>
|
||||
<<Command create-account>>
|
||||
<<Command login>>
|
||||
<<Command passwd>>
|
||||
<<Command users>>
|
||||
<<Command dd>>
|
||||
<<Command repl>>
|
||||
<<Broadcasting>>
|
||||
<<Command-line parsing>>
|
||||
<<Main loop>>
|
||||
<<Test procedures>>
|
||||
<<Global variables.lisp>>
|
||||
<<Table of commands.lisp>>
|
||||
<<Macros.lisp>>
|
||||
<<Little procedures.lisp>>
|
||||
<<Loop's REPL.lisp>>
|
||||
<<Procedures for requests and responses.lisp>>
|
||||
<<Essential operations relative to the index.lisp>>
|
||||
<<How to create and connect to the index.lisp>>
|
||||
<<How to remove inactive users.lisp>>
|
||||
<<How to enumerate inactive accounts.lisp>>
|
||||
<<How to migrate accounts without a creation date.lisp>>
|
||||
<<How to split a stream into lines.lisp>>
|
||||
<<How to create an index from the file system.lisp>>
|
||||
<<How to parse articles.lisp>>
|
||||
<<Dispatching of commands.lisp>>
|
||||
<<Command authinfo.lisp>>
|
||||
<<Command mode reader.lisp>>
|
||||
<<Commands head, body, article.lisp>>
|
||||
<<Command xover.lisp>>
|
||||
<<Command group.lisp>>
|
||||
<<Command list.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>>
|
||||
<<Broadcasting.lisp>>
|
||||
<<Command-line parsing.lisp>>
|
||||
<<Main loop.lisp>>
|
||||
<<Test procedures.lisp>>
|
||||
@ %def
|
||||
|
||||
<<Global variables>>=
|
||||
<<Global variables.lisp>>=
|
||||
(defparameter *debug* nil)
|
||||
<<Representation of accounts>>
|
||||
<<Representation of a client>>
|
||||
<<Representation of requests and responses>>
|
||||
<<Reference to the database>>
|
||||
<<Representation of commands>>
|
||||
<<Representation of articles>>
|
||||
<<Definition of maximum allowed inactive periods>>
|
||||
<<Global variable that decides whether to enable the NNTP REPL>>
|
||||
<<Representation of accounts.lisp>>
|
||||
<<Representation of a client.lisp>>
|
||||
<<Representation of requests and responses.lisp>>
|
||||
<<Reference to the database.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>>
|
||||
@
|
||||
|
||||
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
|
||||
:filesystem-utils :ironclad/digest/sha256
|
||||
@
|
||||
|
|
@ -2974,7 +2983,7 @@ The \lp\ system definition:
|
|||
(asdf:defsystem :<<Name>>
|
||||
:version "<<Version>>"
|
||||
:description "<<Description>>"
|
||||
:depends-on (<<List of packages to be loaded>>)
|
||||
:depends-on (<<List of packages to be loaded.lisp>>)
|
||||
: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
|
||||
and Arnold Robbins in ``sed \& awk'' second edition, pages 112--114.
|
||||
|
||||
<<format-def>>=
|
||||
<<format-def.sh>>=
|
||||
#!/bin/sh
|
||||
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
|
||||
that line and that's all.
|
||||
|
||||
<<make-release>>=
|
||||
<<make-release.sh>>=
|
||||
#!/bin/sh
|
||||
usage()
|
||||
{
|
||||
|
|
|
|||
Loading…
Reference in a new issue