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

Cleans up LOOP completely for coherence with the new io work.

Browse source 
We're ready to tackle the new design on the index, so we're going live
with the current changes so that we can use it every day and spot any
mishaps we might find (while we write the new index subsystem).
This commit is contained in:
Circling Skies 2026-08-06 16:58:12 -03:00
parent 53072ef46f
commit 602f44b464
10 changed files with 93 additions and 382 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

15
Anyfile
View file

@ -31,15 +31,6 @@ format-def: loop.nw
(rm format-def.tmp && exit 1)) && \
mv format-def.tmp format-def
make-release: loop.nw
(no tangle -Rmake-release.sh < loop.nw > make-release.tmp || \
(rm make-release.tmp && exit 1)) && \
mv make-release.tmp make-release && chmod 0755 make-release
release: make-release
./make-release $$(git log --oneline -1 | awk '{print $$1}') \
loop.nw > loop.tmp && mv loop.tmp loop.nw
loop.asd: loop.nw
(no tangle -Rloop.asd < loop.nw > loop-asd.tmp || \
(rm loop-asd.tmp && exit 1)) && \
@ -70,12 +61,6 @@ scripts/migrate-add-creation-date.lisp: loop.nw
mv migrate-add-creation-date.tmp \
scripts/migrate-add-creation-date.lisp
# 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
no weave -delay -index loop.nw > loop.tex

2
Makefile
View file

@ -4,6 +4,6 @@ loop: loop.asd loop.lisp scripts/build-exe.lisp
sbcl --script scripts/build-exe.lisp
install: loop
mkdir -p `head -1 conf-home` && \
mkdir -p `head -1 conf-home`/tmp && \
cp -R loop accounts.lisp groups scripts \
`head -1 conf-home`

22
README
View file

@ -21,7 +21,7 @@ install it as a local project. Go to
and say
$ git clone https://git.antartida.xyz/loop/srv loop
$ git clone https://git.atlantida.space/root/loop
$ cd loop
$ echo /path/to/loop/home > conf-home
$ make install
@ -76,7 +76,7 @@ Using another terminal, telnet to your host on port 1024:
--8<-------------------------------------------------------->8---
$ telnet localhost 1024
Trying 127.0.0.1...
Connected to antartida.xyz.
Connected to 127.0.0.1.
Escape character is '^]'.
200 Welcome! Say ``help'' for a menu.
quit
@ -122,22 +122,6 @@ $ crontab -l
We installed LOOP just fine on
Void GNU/Linux release ``rolling'' with SBCL 2.6.6.void.1
FreeBSD 14.1, 14.2 with SBCL 2.4.9.
Debian GNU/Linux 8.11 codename jessie with SBCL 1.2.4.debian.
(*) Systems with installation issues
We installed LOOP on Ubuntu 24.04 (24.01.1 LTS) codename noble with
SBCL 2.2.9.debian. We found that CLSQL could not load the shared
object libsqlite3.so because ``apt install libsqlite3'' installs the
library at
/usr/lib/x86_64-linux-gnu/libsqlite3.so.0.8.6
with a symbolic link to libsqlite3.so.0, but not to libsqlite3.so.
SBCL is trying to load libsqlite3.so, so a solution is to just tell
your system to
ln -s libsqlite3.so.0 libsqlite3.so
at /usr/lib/x86_64-linux-gnu.

BIN
images/gnus-article.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 119 KiB

BIN
images/sylpheed-reading.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 108 KiB

BIN
images/sylpheed-subscribing.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 12 KiB

95
loop.lisp
View file

@ -17,14 +17,14 @@
(in-package #:loop)
(defparameter *debug* nil)
(defparameter *debug* t)
(defstruct account username seen last-post friends pass pass-locked pass-locked-why creation)
(defparameter *accounts* nil)
(defstruct client group (article 1) (username "ANONYMOUS") (auth? 'no))
(defparameter *client* (make-client))
(defstruct request verb args said)
(defstruct response code data request multi-line)
(defparameter *default-database* nil)
(defstruct command fn verb description)
(defparameter *commands-assoc* nil)
(defstruct article head body)
@ -177,42 +177,18 @@
(defun println (&rest args)
(apply #'out (list* *standard-output* (str:concat (car args) "~%") (cdr args))))
(defun enumerate (ls &optional (first-index 0))
(loop for e in ls and i from first-index
collect (cons i e)))
(defun ucs-2->ascii (bs)
;; I'm a Windows user.
#-win32 bs #+win32 (remove-if #'zerop bs))
(defun bad-input (r msg &key code)
(make-response :code (or code 400) :data msg :request r))
(defun integer->string (n)
(fmt "~a" n))
(defun mkstr (&rest args) ;; a utility
(with-output-to-string (s)
(dolist (a args) (princ a s))))
(defun data (&rest args) ;; a utility
(flatten (map 'list #'data->bytes args)))
(defun crlf ()
(vector 13 10))
(defun crlf-string ()
(fmt "~c~c" #\return #\linefeed))
(defun flatten (obj)
(do* ((result (list obj))
(node result))
((null node) (delete nil result))
(cond ((consp (car node))
(when (cdar node) (push (cdar node) (cdr node)))
(setf (car node) (caar node)))
(t (setf node (cdr node))))))
(defmacro mac (&rest body)
`(macroexpand-1 ,@body))
@ -287,19 +263,6 @@
(when found
(values grp art))))
(defun connect-index! (filename)
(setq *default-database* (clsql:connect (list filename) :database-type :sqlite3)))
(defun create-index! ()
(clsql:execute-command "create table if not exists indices
(id varchar(1000), grp varchar(1000), article varchar(300))")
(clsql:execute-command "create unique index if not exists idx_id_1
on indices (id)"))
(defun drop-create-index! ()
(clsql:execute-command "drop table if exists indices")
(create-index!))
(defun remove-inactive-users! ()
(loop for u in *accounts* do
(let ((username (account-username u)))
@ -901,7 +864,6 @@
(format-timestring nil (now))))
(defun conforms? (bs)
"Convenience wrapper: parse the in-memory article and check headers."
(catch 'article-syntax-error
(conforms-headers?
(article-head (parse-article bs)))))
@ -940,7 +902,7 @@
(string= needle s :end1 len :end2 len)))))
(defun headers-required-from-clients ()
'("from" "newsgroups" "subject"))
'("from" "newsgroups" "subject" "message-id" "date"))
(defun suggest-message-id (&optional (n 20))
(fmt "<~a@loop>" (random-string n)))
@ -954,47 +916,6 @@
(setq mid (cons (char universe (random len state)) mid)))
(coerce mid 'string)))
(defun unparse-article (parsed)
;; 1. Build the new headers as a standard string
(let* ((headers-str (with-output-to-string (s)
(dolist (h (parse-headers (article-head parsed)))
(format s "~a: ~a~c~c" (str:capitalize (car h)) (cdr h) #\return #\linefeed))
;; Add the final \r\n separating headers from the body
(format s "~c~c" #\return #\linefeed)))
;; 2. Convert the string to a small byte array (~1 KB)
(headers-bytes (make-array (length headers-str)
:element-type '(unsigned-byte 8)
:initial-contents (map 'list #'char-code headers-str)))
;; 3. Get the displaced, zero-copy body array
(body-bytes (article-body parsed)))
(concatenate '(vector (unsigned-byte 8)) headers-bytes body-bytes)))
(defun ensure-header (h fn bs)
(let* ((headers (parse-headers (article-head (parse-article bs)))))
(if (lookup h headers)
bs
(unparse-article
(make-article
:head
(str:join (crlf-string)
(mapcar #'(lambda (h)
(fmt "~a: ~a" (car h) (cdr h)))
(cons (cons h (funcall fn)) headers)))
:body (article-body (parse-article bs)))))))
(defun get-date ()
(multiple-value-bind (s m h day mon year dow dst-p tz)
(get-decoded-time)
(declare (ignore dow dst-p))
(fmt "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d GMT~a"
year mon day h m s (- tz))))
(defun ensure-mid (bs)
(ensure-header "message-id" #'suggest-message-id bs))
(defun ensure-date (bs)
(ensure-header "date" #'get-date bs))
(defun cmd-post (r)
(with-auth
(let ((suggested (suggest-message-id)))
@ -1102,7 +1023,6 @@
(loop
;; 1. Fetch a clean line from your highly optimized buffer
(let ((line (nntp-read-line)))
;(stderr "read line: ~a~%" line)
;; 2. Detect terminator: A line containing exactly the byte 46 ('.')
(when (end-of-article? line)
(setf success t)
@ -1276,7 +1196,8 @@
(with-n-args 1 r
(let* ((args (mapcar #'str:upcase (request-args r)))
(username (car args)))
(multiple-value-bind (username pass-or-error) (new-account! username (client-username *client*))
(multiple-value-bind (username pass-or-error)
(new-account! username (client-username *client*))
(if (not username)
(make-response :code 400 :request r
:data (fmt "~a. Choose a new name." pass-or-error))
@ -1442,7 +1363,8 @@
(eq (sxhash pass) (account-pass u)))
((arrayp (account-pass u))
(equalp (string->sha256 pass) (account-pass u)))
(t (error "pass? expected to find INTEGERP or ARRAYP but found ~a" (type-of (account-pass u))))))))
(t (error "pass? expected to find INTEGERP or ARRAYP but found ~a"
(type-of (account-pass u))))))))
(defun change-passwd! (username newpass)
(let ((u (get-account username)))
@ -1626,8 +1548,6 @@
(defun cli/main (cmd)
(read-accounts!)
(connect-index! "message-id.db")
(create-index!)
(let ((args (clingon:command-arguments cmd))
(run-server t)
(repl (clingon:getopt cmd :repl))
@ -1666,6 +1586,7 @@
(loop
(let* ((bs (nntp-read-line))
(ln (bytes->string bs)))
(stderr "<<< ~a~%" ln) ;; for logging
(let ((r (send-response! (dispatch-line ln))))
(when (response-quit? r)
(return)))))

337
loop.nw
View file

@ -9,8 +9,8 @@
\usepackage[T1]{fontenc}
\usepackage[utf8]{inputenc}
\usepackage[english]{babel}
\usepackage{csquotes}
\usepackage{babel}
\usepackage{etoolbox}
\AtBeginEnvironment{quote}{\small}
@ -56,9 +56,8 @@
\Lp\ is an out-of-fashion program, used as medium of communication by
antiquated people. \Lp\ members insist that technical communication
be made in writing and not in a hurry. To give you an idea, they
write \Lp\ in jurassic technology. You wouldn't pay them any
attention.
be made in writing, anxiety-free. To give you an idea, they write
\Lp\ in jurassic technology---you wouldn't pay them any attention.
%
\begin{verbatim}
Drunk and dressed in their best brown baggies and their platform soles
@ -67,10 +66,10 @@ attention.
-- Mark Knopfler, 1978.
\end{verbatim}
It's easy to make a conference on the Internet. E-mail works. When
we write an e-mail to various friends to discuss a certain subject, we
form a circle. When we decide to add another person to this
quickly-made conference by e-mail, sometimes we use a well-known
It's easy to make a conference on the Internet. E-mail suffices.
When we write an e-mail to various friends to discuss a certain
subject, we form a circle. When we decide to add another person to
this quickly-made conference by e-mail, sometimes we use a well-known
idiom---``adding John to the loop''. We add John's e-mail address to
the list of destinataries. So long as everyone replies to everyone,
John too will get all the messages. If anyone violates this rule of
@ -555,6 +554,7 @@ the user says {\tt QUIT}, then we should identify it and terminate
(loop
(let* ((bs (nntp-read-line))
(ln (bytes->string bs)))
(stderr "<<< ~a~%" ln) ;; for logging
(let ((r (send-response! (dispatch-line ln))))
(when (response-quit? r)
(return)))))
@ -586,7 +586,7 @@ the user says {\tt QUIT}, then we should identify it and terminate
(defun welcome-message ()
(cl-ppcre:regex-replace-all "HASH" "<<Welcome message>>" *git-hash*))
@ %def main
@ %def main welcome-message
\noindent It's always useful to know which version exactly we're
dealing with:
@ -740,8 +740,6 @@ service starts with [[server-start]].
(defun cli/main (cmd)
(read-accounts!)
(connect-index! "message-id.db")
(create-index!)
(let ((args (clingon:command-arguments cmd))
(run-server t)
(repl (clingon:getopt cmd :repl))
@ -1124,8 +1122,7 @@ two commands---{\tt AUTHINFO user} and {\tt AUTHINFO pass}. So we
also implemented the command {\tt LOGIN}---see
Section~\ref{sec:login}. To check the user's password, we use the
procedure [[pass?]] that's defined in the implementation of {\tt
PASSWD}. Perhaps we should have called it {\tt
is-password-correct?} or something more obvious.
PASSWD}.
<<authinfo error message>>=
Syntax error. Say ``authinfo USER /your-name/'' then ``authinfo PASS /your-pass/''.
@ -1195,7 +1192,8 @@ it's their problem.
(with-n-args 1 r
(let* ((args (mapcar #'str:upcase (request-args r)))
(username (car args)))
(multiple-value-bind (username pass-or-error) (new-account! username (client-username *client*))
(multiple-value-bind (username pass-or-error)
(new-account! username (client-username *client*))
(if (not username)
(make-response :code 400 :request r
:data (fmt "~a. Choose a new name." pass-or-error))
@ -1248,13 +1246,11 @@ it's their problem.
(values (str:upcase username) p))))))
@ %def CREATE-ACCOUNT new-account!
Notice that we have a race condition in [[write-accounts]]. What is
the problem? Two processes in parallel may ask for the writing of
[[accounts.lisp]]. The process that loses the race will have its
modifications lost. What do we need to do? Either we use file
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. I think we need locking.
To write [[write-accounts!]] we will need locking, no way to avoid
this given the parallel daily-nature of \Lp. Two processes in
parallel may ask for the writing of [[accounts.lisp]]. The process
that loses the race would have its modifications lost. What do we
need to do? We need locking no matter what.
<<Command create-account.lisp>>=
(defmacro with-file-lock ((lock-path &key (sleep-time 0.1) (retries 50)) &body body)
@ -1343,9 +1339,9 @@ unlock it.
\subsection{{\tt LOGIN}}\label{sec:login}
Besides {\tt AUTHINFO} in Section~\ref{sec:authinfo}, we also
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}.
implement a more convenient command for authentication when we
interact with \lp\ through a command-line interface. Instead of
having to say two commands, we can just say {\tt login user password}.
<<Command login.lisp>>=
(defun cmd-login (r)
@ -1366,7 +1362,7 @@ two commands, we can just say {\tt login user password}.
(defun log-user-in-as! (name)
(setf (client-username *client*) name)
(log-user-in!))
@ %def log-user-in-as!
@
\subsection{{\tt PASSWD}}\label{sec:passwd}
@ -1403,7 +1399,8 @@ there is a macro emerging here called [[with-upcase-args]]. %% TODO
(eq (sxhash pass) (account-pass u)))
((arrayp (account-pass u))
(equalp (string->sha256 pass) (account-pass u)))
(t (error "pass? expected to find INTEGERP or ARRAYP but found ~a" (type-of (account-pass u))))))))
(t (error "pass? expected to find INTEGERP or ARRAYP but found ~a"
(type-of (account-pass u))))))))
(defun change-passwd! (username newpass)
(let ((u (get-account username)))
@ -1866,12 +1863,10 @@ I'm going to remove this very soon.
\subsection{{\tt POST}}\label{sec:post}
If the client says {\tt POST}, then we continue to read line after
line until we find \verb|".\r\n"|. Having done that, we must check
whether we have a conformant article at hands. The definition of
conformant is given by [[conforms?]]. In a few words, the article
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|.)
line until we find \verb|.\r\n|. Having done that, we must check
whether we have a conformant article at hand. The definition of
conformant is given by [[conforms?]]: the article must have the
headers required by [[headers-required-from-clients]].
<<Command post.lisp>>=
<<Does an article conform?.lisp>>
@ -1888,60 +1883,6 @@ must have \verb|message-id|, \verb|subject|, \verb|from|,
(coerce mid 'string)))
@
Sometimes we parse an article and sometimes we want to undo that
parsing. Am I doing something wrong? I wonder. We surely are, but
now is not the time for fixing this.
<<Command post.lisp>>=
(defun unparse-article (parsed)
;; 1. Build the new headers as a standard string
(let* ((headers-str (with-output-to-string (s)
(dolist (h (parse-headers (article-head parsed)))
(format s "~a: ~a~c~c" (str:capitalize (car h)) (cdr h) #\return #\linefeed))
;; Add the final \r\n separating headers from the body
(format s "~c~c" #\return #\linefeed)))
;; 2. Convert the string to a small byte array (~1 KB)
(headers-bytes (make-array (length headers-str)
:element-type '(unsigned-byte 8)
:initial-contents (map 'list #'char-code headers-str)))
;; 3. Get the displaced, zero-copy body array
(body-bytes (article-body parsed)))
(concatenate '(vector (unsigned-byte 8)) headers-bytes body-bytes)))
@ %def unparse-article
If an article being posted has no \verb|message-id| or \verb|date|,
\lp\ provides these headers. We kill these two rabbits with
[[ensure-header]], but we should probably make a table of headers and
procedures that would generate such headers if they're missing. Right
now, however, we have only these two to worry about.
<<Command post.lisp>>=
(defun ensure-header (h fn bs)
(let* ((headers (parse-headers (article-head (parse-article bs)))))
(if (lookup h headers)
bs
(unparse-article
(make-article
:head
(str:join (crlf-string)
(mapcar #'(lambda (h)
(fmt "~a: ~a" (car h) (cdr h)))
(cons (cons h (funcall fn)) headers)))
:body (article-body (parse-article bs)))))))
(defun get-date ()
(multiple-value-bind (s m h day mon year dow dst-p tz)
(get-decoded-time)
(declare (ignore dow dst-p))
(fmt "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d GMT~a"
year mon day h m s (- tz))))
(defun ensure-mid (bs)
(ensure-header "message-id" #'suggest-message-id bs))
(defun ensure-date (bs)
(ensure-header "date" #'get-date bs))
@ %def ensure-mid ensure-date
Now it's time to look at the header \verb|newsgroups|. The name of
each group must conform to the expression
@ -2091,15 +2032,8 @@ iteration (and it's the loop for x from x that makes the increments).
(1+ high)))
@ %def save-article-insist get-next-article-id
{\bf How to read lines in the NNTP protocol?} We've implemented the
most trivial strategy possible in [[nntp-read-line-slow]]. It's also
the slowest, so we don't use it anymore but we keep it here to tell
the story. For speed reasons, life is complicated here, so let's take
things one at a time. First of all, how do we read an article? Well,
we read a line and---if that line happens to be a lonely dot, then
that's the end of the article, so we just return a list of
lines. Otherwise, we continue by attaching the new line to the end of
our accumulated list of lines.
{\bf How to read lines in the NNTP protocol?} We need a new
presentation here and a clean up operation.
<<Command post.lisp>>=
(defun nntp-read-article-to-disk (tmp-path)
@ -2112,7 +2046,6 @@ our accumulated list of lines.
(loop
;; 1. Fetch a clean line from your highly optimized buffer
(let ((line (nntp-read-line)))
;(stderr "read line: ~a~%" line)
;; 2. Detect terminator: A line containing exactly the byte 46 ('.')
(when (end-of-article? line)
(setf success t)
@ -2362,7 +2295,6 @@ unclear right now what the wise measure is, so we'll keep on moving.
<<Does an article conform?.lisp>>=
(defun conforms? (bs)
"Convenience wrapper: parse the in-memory article and check headers."
(catch 'article-syntax-error
(conforms-headers?
(article-head (parse-article bs)))))
@ -2401,13 +2333,16 @@ unclear right now what the wise measure is, so we'll keep on moving.
(string= needle s :end1 len :end2 len)))))
(defun headers-required-from-clients ()
'("from" "newsgroups" "subject"))
@ %def conforms?
'("from" "newsgroups" "subject" "message-id" "date"))
@ %def conforms? headers-required-from-clients
Notice that to simplify matters we're duplicating articles
cross-posted. What we should do is write the article to the first
group in the list of \verb|newsgroups| and then make a symbolic link
to all others.
to all others. Why are we saying this here? This should be said in
the [[post]] procedure. You know what? Let's commit what we have
right now and let's tackle the index. We gotta push on through. (But
while I'm gone I meant it---everything is gonna be alright.)
\subsection{{\tt CREATE-GROUP}}
@ -2579,82 +2514,17 @@ that the number 37 is not inside the article, but only in the name of
the file stored in the file system. The index, therefore, knows in
which file is each {\tt message-id}. This fact implies that you
cannot rename files in the file system---of course not: you'd changing
identifiers inside a database. If you have rename a file, you will
need to rebuild the index. Given that the index is an SQL table, you
can adjust the index relative to the any files you may need to rename
for whatever reason. You can also rebuild the entire index by reading
the file system---unless you have a lot of files, that's probably the
easiest thing to do.
identifiers inside a database.
The use of [[*default-database*]] by the library [[clsql]] is very
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.lisp>>=
(defparameter *default-database* nil)
@ %def *default-database*
<<How to create and connect to the index.lisp>>=
(defun connect-index! (filename)
(setq *default-database* (clsql:connect (list filename) :database-type :sqlite3)))
(defun create-index! ()
(clsql:execute-command "create table if not exists indices
(id varchar(1000), grp varchar(1000), article varchar(300))")
(clsql:execute-command "create unique index if not exists idx_id_1
on indices (id)"))
(defun drop-create-index! ()
(clsql:execute-command "drop table if exists indices")
(create-index!))
@ %def create-index! drop-create-index! connect-index!
Of course, the creation and connection of the index must occur before
[[main-loop]], so it takes place in [[main]].
When someone requests an article, it's either by its numeric index but
then the client has already chosen a group, or it's by its {\tt
message-id}. We don't need to tell the client to which groups the
article belongs; we just give the entire article to the client. It
is, therefore, the client's responsibility what to do with the
article. However, to fetch an article, we need to know where in the
database (in the file system) is the article; in other words, we must
know one group in which the article was stored. This implies that the
index must know at least one group. We've decided to always index the
first group in the {\tt newsgroups} header. So the index's anatomy is
$(m, g, i)$, where $m$ is the {\tt message-id}, $g$ is the name of the
group and $i$, is the name of the article in the file system. This
also defines the anatomy of the SQL table.
Should we store more information in the index? Not really. If we
need anything about an article, we can get it after we fetch it from
the file system. For example, suppose that a search command wishes to
display the fact that article was posted in various groups. Suppose
further the command has already located in the index an article to be
displayed. This means the command has the {\tt message-id} and one of
the groups in which the article was posted. The command is then able
to fetch the entire article from the file system. Now it's a matter
of reading the article itself to know almost everything there is to
know about it. (It's also interesting that we keep the index thin
because we need to allow it to grow to great sizes.)
%% (clsql:create-table "INDICES" '(([id] (string 1000)) ([grp] (string 1000)) ([article] (string 300))))
%% (clsql:execute-command "create table if not exists indices (id varchar(1000), grp varchar(1000), article varchar(300))")
%% LOOP> (clsql:create-index "idx_id_1" :on "indices" :attributes "id" :unique "id")
%% ; No value
%% (clsql:execute-command "CREATE UNIQUE INDEX if not exists idx_id_1 ON INDICES (ID)")
%% CL-USER> (clsql:list-attributes "indices")
%% ("ID" "GRP" "ARTICLE")
%% CL-USER> (clsql:insert-records :into "indices" :attributes '(id grp article) :values '("<87plr25js5.fsf@tor.soy>" "comp.unix" 37))
%% ; No value
%% CL-USER> (clsql:select 'id 'grp 'article :from "indices")
%% (("<87plr25js5.fsf@tor.soy>" "comp.unix"))
%% ("ID" "GRP")
At this very moment we're designing the index. We're removing all
references to the previous index. We're going to use a two-level UNIX
directory. Every message id will be hashed to a {\tt hashid} and the
hard link on the file system will be written in directory {\tt
index/ha/sh/id}. I believe a two-level will be enough for
\Lp---it's a system for a loop of friends. Though the code is dead,
I'm keeping the next section here because we'll likely keep the
procedure names, so seeing here will remind me what needs to be
rewritten.
\section{Essential operations relative to the index}
@ -2741,13 +2611,13 @@ once. Here's how to use it:
%
\begin{verbatim}
%pwd
/home/dbastos/loop
/home/me/loop
%sbcl --script build-index-from-fs.lisp
Index built.
%ls -l message-id.db
-rw-r--r-- 1 dbastos wheel 65536 Aug 26 13:32 message-id.db
-rw-r--r-- 1 me wheel 65536 Aug 26 13:32 message-id.db
\end{verbatim}
\section{Deletion and locking of inactive accounts}\label{sec:inactive-users}
@ -2756,7 +2626,7 @@ We now implement some of the \hyperref[principles]{principles} exposed
earlier on page~\pageref{principles}. The program
@<<cron-remove-inactive-users.lisp@>> would be run by {\tt cron} every
day (at midnight, say). It checks all accounts that are inactive and
either locks them. If you want to keep accounts forever, just don't
locks them. If you want to keep accounts forever, just don't
run the program. I've decided to never delete accounts that are
inactive, so I only lock them.
@ -2828,7 +2698,7 @@ Accounts that do not have a creation date up until today---Tue Sep 17
\Lp\ was written. But notice that this migration is done only once.
New system administrators of \Lp\ will never need to run this. (We do
not remove this set of source code chunks because they serve as an
example of how to a migration like that.)
example of how to do a migration of this sort.)
<<How to migrate accounts without a creation date.lisp>>=
(defun loop-epoch ()
@ -2841,7 +2711,7 @@ example of how to a migration like that.)
(setf (account-creation u) (timestamp-to-universal (loop-epoch)))
(setf (account-last-post u) (account-seen u))))
(write-accounts!))
@ %def migrate-add-creation-and-post-date! loop-epoch
@ %def migrate-add-creation-and-post-date!
Here's a program to run the migration in a UNIX shell.
@ -2851,7 +2721,7 @@ Here's a program to run the migration in a UNIX shell.
(in-package #:loop)
(migrate-add-creation-and-post-date!)
(format t "Accounts rewritten.~%")
@ %def migrate-add-creation-date.lisp
@
Now we write the procedures that discover what accounts are inactive.
@ -2911,7 +2781,7 @@ Now we write the procedures that discover what accounts are inactive.
(format t "Username ~a is inactive? ~a~%"
(account-username u)
(user-inactive? (account-username u)))))
@ %def list-inactive-users
@
\section{Macros to ease writing}\label{sec:dsl}
@ -2978,13 +2848,7 @@ any more.
\section{Other procedures}
Of small importance, they have nothing. Notice that [[ucs-2->ascii]]
is iseful only in Windows systems---and just for development. The
procedure destructively converts UCS-2 to ASCII, so it's only really
useful when we're converting an implicitly ASCII-content in the form
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.
Of small importance, they have nothing.
<<Little procedures.lisp>>=
(defun conforms-to? (s re &optional error-msg)
@ -3026,67 +2890,44 @@ means 2 bytes. So our conversion is just removing the first byte.
(defun println (&rest args)
(apply #'out (list* *standard-output* (str:concat (car args) "~%") (cdr args))))
(defun enumerate (ls &optional (first-index 0))
(loop for e in ls and i from first-index
collect (cons i e)))
(defun ucs-2->ascii (bs)
;; I'm a Windows user.
#-win32 bs #+win32 (remove-if #'zerop bs))
(defun bad-input (r msg &key code)
(make-response :code (or code 400) :data msg :request r))
(defun integer->string (n)
(fmt "~a" n))
(defun mkstr (&rest args) ;; a utility
(with-output-to-string (s)
(dolist (a args) (princ a s))))
(defun data (&rest args) ;; a utility
(flatten (map 'list #'data->bytes args)))
(defun crlf ()
(vector 13 10))
(defun crlf-string ()
(fmt "~c~c" #\return #\linefeed))
(defun flatten (obj)
(do* ((result (list obj))
(node result))
((null node) (delete nil result))
(cond ((consp (car node))
(when (cdar node) (push (cdar node) (cdr node)))
(setf (car node) (caar node)))
(t (setf node (cdr node))))))
(defmacro mac (&rest body)
`(macroexpand-1 ,@body))
@ %def bad-input crlf mkstr data crlf-string flatten ucs-2->ascii enumerate
@ %def bad-input crlf crlf-string
\section{Tests}
I studied the minimum to be able to add these tests as we comprehend
better the direction in which we're going. A test system is essential
for us to trust we can move forward without breaking important past
decisions in the code. XXX: we should not include these tests in
decisions in the code. We should not include these tests in
production code as we are doing right now. Divert them to a tests
package or something that makes more sense. To run the tests, you
need to invoke [[lisp-unit:run-tests]]. I believe that invoking it in
a script will make all tests run. Oh, that should be included the
binary, too, so that we can always test an archived project. That's a
good idea. Make it a clingon option on the command line. Of course,
by including tests in the executable, we should isolate all the tests
here. I know how---just define a test package and isolate it all in
it. Packages are for namespace isolation. Lisp's ``systems'' are the
type of packaging meant for loading. Lisp's ``packages'' are merely
namespace isolation. Our test package should use \lp's package, so
that we can use any of the procedures under testing. When we define a
variable, it will be defined in the test package, not in \lp's, but
when we are in \lp's package, we see no names of the test package.
It's simple and a good solution.
good idea. Make it a clingon option on the command line, though
remember we will get rid of clingon. Of course, by including tests in
the executable, we should isolate all the tests here. I know
how---just define a test package and isolate it all in it. Packages
are for namespace isolation. Lisp's ``systems'' are the type of
packaging meant for loading. Lisp's ``packages'' are merely namespace
isolation. Our test package should use \lp's package, so that we can
use any of the procedures under testing. When we define a variable,
it will be defined in the test package, not in \lp's, but when we are
in \lp's package, we see no names of the test package. It's simple
and a good solution.
When testing, it's important for us not to clutter a production
system---we will want to run tests on production systems. So what we
@ -3121,12 +2962,8 @@ A bad test from the biggest mouth of the south.
"))
@ %def
XXX: we got a problem with test [[post-okay]]. We're getting an
execution error, but we can't see any error message. The posting is
taking place---here in the REPL at least.
XXX: I removed the tests. We're making so many deep changes that we
need to rethink the tests.
I removed the tests. The most central piece of the system has been
rewritten.
\section{How to produce the binary executable}
@ -3147,7 +2984,7 @@ Just say {\tt make loop} to your shell.
(user-homedir-pathname))))
(when (probe-file quicklisp-init)
(load quicklisp-init)))
@ %def quicklisp
@
\section{How to get a log of \lp's communication}
@ -3260,7 +3097,7 @@ something to think about.
@ %def
<<Global variables.lisp>>=
(defparameter *debug* nil)
(defparameter *debug* t)
<<Representation of accounts.lisp>>
<<Representation of a client.lisp>>
<<Representation of requests and responses.lisp>>
@ -3294,7 +3131,7 @@ The \lp\ system definition:
\section{Other source code}
The shell script {\tt format-def} is invoked whenever we build any
lisp source code. That's to format the source code a bit better for
Lisp source code. That's to format the source code a bit better for
readers that will be reading it directly. It is not what we do. We
read the documentation in PDF format and we work on the NOWEB file
{\tt loop.nw}. But we know that potential readers will not do the
@ -3345,31 +3182,13 @@ $ git log --oneline | head -1 | awk '{print $1}'
52663d1
\end{verbatim}
%
To include this version string in the executable, we need to make it
part of the source code. We get help from {\tt sed} once again. As
the usage explains, we invoke it as {\tt ./make-release 52663d1
loop.nw}. The script then rewrites {\tt loop.nw} with the string in
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.sh>>=
#!/bin/sh
usage()
{
printf 'usage: %s tag file\n' $0
exit 1
}
test $# -lt 2 && usage
tag="$1"; shift
sed "/<<Version>>=/ {
n;
c\\
$tag
}" "$@"
@
We achieve this with [[version.lisp]], which we generate before any
release. This a bit of meta source code we use included in a meta
Makefile we maintain. It's perfectly fine if you assume that
[[version.lisp]] is manually written before we release a new version.
When \Lp\ displays the welcome banner, the procedure
[[welcome-message]] replaces the string [[HASH]] with the hash spelled
out in [[version.lisp]].
\section*{Index of chunks}
\nowebchunks

2
make-release
View file

@ -8,7 +8,7 @@ usage()
test $# -lt 2 && usage
tag="$1"; shift
sed "/a89e088=/ {
sed "/0.0.1=/ {
n;
c\\
$tag

2
version.lisp Normal file
View file

@ -0,0 +1,2 @@
(in-package :loop)
(defparameter *git-hash* "9f48666")