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

Makes lots of changes. (See full log.)

Browse source 
- Converts Makefile to UNIX line termination.

Makefiles cannot be formatted with DOS CRLF because, otherwise, we
could not escape \n to continue on a second line.  We end up escaping
\r and not \n.

- Fixes remove-account!

Procedure delete-if ``may modify sequence'', but we cannot be sure it
will modify it.  There are cases in which it does and there are cases
in which it doesn't.  Seeing it did modify in one case, I incorrectly
assumed it would modify in all cases---such is life.  Since I do want
to modify it always, I wrote delete-if*, which in calls setf to be
sure the list is overwritten.

- Avoids (load'ing "~/.sbclrc") and, instead, does what Quicklisp does.

It's not always the case that ~/.sbclrc exists.  But Quicklisp in each
installation knows what to do.  So we do what Quicklisp does in each
script that we use.

- Frees us from using sb-ext:{file-exists,file-does-not-exist}

Turns out SBCL 1.2.4.debian doesn't have these symbols.

- Adds command-line parsing.
- Adds install target to Makefile.
This commit is contained in:
Circling Skies 2024-12-05 19:03:09 -03:00
parent a104a2d865
commit fce6c784f7
20 changed files with 842 additions and 360 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

146
Makefile
View file

@ -1,79 +1,67 @@
SHELL=/bin/sh
REMOTE=dbastos@antartida.xyz
REMOTE_LIB_PATH=quicklisp/local-projects
REMOTE_EXE_PATH=loop-test
SERVICE_NAME=loop-test
default:
@echo "Sorry. You need to read the Makefile to know what I can make for you."
all: loop.lisp build-exe.lisp exe run \
migrate-add-creation-date.lisp cron-remove-inactive-users.lisp
live: all remote-copy # remote-build-exe
remote-copy:
scp loop.asd loop.lisp \
$(REMOTE):$(REMOTE_LIB_PATH)/loop
scp build-exe.lisp \
$(REMOTE):$(REMOTE_EXE_PATH)/
scp migrate-add-creation-date.lisp \
$(REMOTE):$(REMOTE_EXE_PATH)/
scp cron-remove-inactive-users.lisp \
$(REMOTE):$(REMOTE_EXE_PATH)/
sync-users:
scp $(REMOTE):$(REMOTE_EXE_PATH)/accounts.lisp .
remote-build-exe:
plink -ssh $(REMOTE) cd $(REMOTE_EXE_PATH)/ && \
sbcl --script build-exe.lisp && \
echo "Executable built."
remote-migrate-account-creation:
plink -ssh $(REMOTE) cd $(REMOTE_EXE_PATH)/ && \
sbcl --script migrate-add-creation-date.lisp
remote-cron-remove-inactive-users:
plink -ssh $(REMOTE) cd $(REMOTE_EXE_PATH)/ && \
sbcl --script remote-cron-remove-inactive-users.lisp
livedoc:
echo loop.nw | python peat -C 'make loop.pdf'
run: loop.nw
(any tangle -Rrun < loop.nw > run.tmp || (rm run.tmp && exit 1)) && \
mv run.tmp run.lisp && \
chmod 0755 run
loop.tex: loop.nw
any weave -delay -index loop.nw > loop.tex
loop.pdf: loop.tex
latexmk -pdf loop
loop.lisp: loop.nw
(any tangle -Rloop.lisp < loop.nw > loop.tmp || (rm loop.tmp && exit 1)) && \
mv loop.tmp loop.lisp
build-exe.lisp: loop.nw
(any tangle -Rbuild-exe.lisp < loop.nw > build-exe.tmp || (rm build-exe.tmp && exit 1)) && \
mv build-exe.tmp build-exe.lisp
build-index-from-fs.lisp: loop.nw
(any 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 build-index-from-fs.lisp
cron-remove-inactive-users.lisp: loop.nw
(any 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 cron-remove-inactive-users.lisp
migrate-add-creation-date.lisp: loop.nw
(any 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 migrate-add-creation-date.lisp
exe: loop.lisp build-exe.lisp
sbcl --script build-exe.lisp && echo "Executable built okay."
service: run
sudo ln -s $(pwd) /service/$(SERVICE_NAME)
default:
@echo "Sorry. See Makefile to know what I can make for you."
all: loop loop.lisp loop.asd \
scripts/build-exe.lisp \
scripts/cron-remove-inactive-users.lisp \
scripts/build-index-from-fs.lisp \
scripts/migrate-add-creation-date.lisp
clean:
rm -f *.pdf *.out *.aux *.log *.fls *.fdb_latexmk loop loop.tex
build: loop.lisp loop.asd scripts/build-exe.lisp
sbcl --script scripts/build-exe.lisp
install: loop
mkdir -p `head -1 conf-home` && \
cp -R loop accounts.lisp groups scripts `head -1 conf-home`
loop: loop.lisp scripts/build-exe.lisp
sbcl --script scripts/build-exe.lisp
loop.lisp: loop.nw
(any tangle -Rloop.lisp < loop.nw > loop.tmp || \
(rm loop.tmp && exit 1)) && \
mv loop.tmp loop.lisp
loop.asd: loop.nw
(any 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.nw
(any 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 > \
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 > \
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
migrate-add-creation-date.lisp: loop.nw
(any 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 > run.tmp || (rm run.tmp && exit 1)) && \
mv run.tmp run && \
chmod 0755 run
loop.tex: loop.nw
any weave -delay -index loop.nw > loop.tex
loop.pdf: loop.tex
latexmk -pdf loop

153
README Normal file
View file

@ -0,0 +1,153 @@
(*) Introduction
LOOP is an NNTP server written in Common Lisp.
(*) Assumptions
We assume
- you run SBCL
- you have Quicklisp installed and knows how to use it
- you know how to use a TCP server such as
https://cr.yp.to/ucspi-tcp.html
- you know how to manage a daemon with
https://cr.yp.to/daemontools.html
- you have git and knows how to use it
(*) How to install it
LOOP is not in the Quicklisp repository, so we'll instruct you to
install it as a local project. Go to
~/quicklisp/local-projects/
and say
$ git clone https://git.antartida.xyz/loop/srv loop
$ cd loop
$ make build
If you just installed SBCL and quicklisp, the build might take a
little while to download some dependencies. Now you have the
executable loop. Try it out:
--8<-------------------------------------------------------->8---
$ ./loop --help
NAME:
loop - An NNTP server for a circle of friends.
USAGE:
loop [options] [arguments ...]
OPTIONS:
--change-passwd <VALUE> <username> <new-password> changes password
--create-account <VALUE> <username> <invited-by> creates a new account
--help display usage information and exit
--logging turn on debug logging on stderr
--version display version and exit
-l, --list-accounts lists accounts
-r, --repl run a REPL on port 4006
-s, --server runs NNTP server reading from stdout
AUTHORS:
Circling Skies <loop@antartida.xyz>
LICENSE:
GPL v3
--8<-------------------------------------------------------->8---
You can talk to the NNTP server with -s:
--8<-------------------------------------------------------->8---
$ ./loop -s
200 Welcome! Say ``help'' for a menu.
quit
205 Good-bye.
--8<-------------------------------------------------------->8---
It's time to choose a directory from which LOOP will run. Say you
choose $HOME/loop. Then say
$ echo $HOME/loop > conf-home
$ make install
Whenever you run loop, make sure you're in its home directory because
it will look for the file accounts.lisp always relatively to the
current working directory of the process. (So, if you set up a cron
job, make sure the job, too, sets LOOP's home directory as its current
working directory.)
(*) Create your account
LOOP requires authentication for most things, so you should create an
account for you right away. Accounts are kept in accounts.lisp in
your installation directory. Every time you create an account, you
must specify who is inviting this new account into the LOOP---because
we keep a tree of accounts. The root account is called anonymous, so
your first account must be invited by the anonymous account. So you
can say
./loop --create-account you anonymous
The anonymous account has no special power. It exists solely because
the graph of accounts needs a root.
(*) How to expose it to the network
Just have your system run your TCP server of choice. For instance, if
you're using djb's tcpserver and would like LOOP to listen on port
1024, tell your shell
--8<-------------------------------------------------------->8---
$ tcpserver -v -HR 0.0.0.0 1024 ./loop -s
tcpserver: status: 0/40
--8<-------------------------------------------------------->8---
Using another terminal, telnet to your host on port 1024:
--8<-------------------------------------------------------->8---
$ telnet localhost 1024
Trying 127.0.0.1...
Connected to antartida.xyz.
Escape character is '^]'.
200 Welcome! Say ``help'' for a menu.
quit
205 Good-bye.
Connection closed by foreign host.
--8<-------------------------------------------------------->8---
Directories daemon/ and daemon-tls/ in LOOP's source code have sample
scripts to use with djb's tcpserver and daemontools. If you have
never done this, it will be better education if you learn to use
daemontools and ucspi-tcp before going live with a LOOP community.
It's easy and fun.
(*) Systems with no installation issues
We installed LOOP just fine on
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.

5
build-exe.lisp
View file

@ -1,5 +0,0 @@
(load "~/.sbclrc")
(ql:quickload :loop :silent t)
(sb-ext:save-lisp-and-die #P"loop.exe"
:toplevel #'loop:main
:executable t)

7
build-index-from-fs.lisp
View file

@ -1,7 +0,0 @@
(load "~/.sbclrc")
(ql:quickload :loop :silent t)
(in-package #:loop)
(connect-index! "message-id.db")
(remake-index!)
(index-from-fs!)
(format t "Index built.~%")

4
conf-home Normal file
View file

@ -0,0 +1,4 @@
~/loop
The executable and the ucspi-tcp-tcpserver service will be installed
at this directory.

8
cron-remove-inactive-users.lisp
View file

@ -1,8 +0,0 @@
(load "~/.sbclrc")
(ql:quickload :loop :silent t)
(in-package #:loop)
;; (format t *default-pathname-defaults*)
(read-accounts!)
(connect-index! "message-id.db")
(remove-inactive-users!)
(write-accounts!)

7
groups/local.control.news/2
View file

@ -1,7 +0,0 @@
Date: 2024-12-05 07:27:01 GMT-3
Message-Id: <kocaojivldajgfnjiiou@loop>
From: Loop
Subject: account HIMMEL removed by Loop
Newsgroups: local.control.news
HIMMEL didn't log in a first time (for 1 month) since account creation.

7
groups/local.control.news/3
View file

@ -1,7 +0,0 @@
Date: 2024-12-05 07:52:39 GMT-3
Message-Id: <tjvhrdqxpqiyixsodahj@loop>
From: Loop
Subject: account HIMMEL removed by Loop
Newsgroups: local.control.news
HIMMEL didn't log in a first time (for 1 month) since account creation.

7
groups/local.control.news/4
View file

@ -1,7 +0,0 @@
Date: 2024-12-05 07:52:39 GMT-3
Message-Id: <qpxbepgswiifybcnycow@loop>
From: Loop
Subject: account MFELIX locked by Loop
Newsgroups: local.control.news
MFELIX disappeared for over 3 months.

7
groups/local.control.news/5
View file

@ -1,7 +0,0 @@
Date: 2024-12-05 07:52:39 GMT-3
Message-Id: <ygvnlcmcrzcmtreismjl@loop>
From: Loop
Subject: account KIMOCHI locked by Loop
Newsgroups: local.control.news
KIMOCHI disappeared for over 3 months.

7
groups/local.control.news/6
View file

@ -1,7 +0,0 @@
Date: 2024-12-05 07:52:39 GMT-3
Message-Id: <zjccjxlroztlxteeoakf@loop>
From: Loop
Subject: account WILLIAMP locked by Loop
Newsgroups: local.control.news
WILLIAMP disappeared for over 3 months.

7
groups/local.control.news/7
View file

@ -1,7 +0,0 @@
Date: 2024-12-05 07:52:39 GMT-3
Message-Id: <gdcqooyqhkxanqnaxfvc@loop>
From: Loop
Subject: account JPMAB locked by Loop
Newsgroups: local.control.news
JPMAB disappeared for over 3 months.

7
groups/local.test/1.~1~
View file

@ -1,7 +0,0 @@
Date: 2024-03-07 21:44:31 GMT-3
Message-Id: <edjocyeqzqqhnswlbrbo@loop>
From: Loop
Subject: let there be light
Newsgroups: local.control.news
A sample group.

13
loop.asd
View file

@ -1,14 +1,7 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*-
(asdf:defsystem :loop
:version "0.1"
:description "An NNTP server written in Lisp for a circle of friends."
:depends-on (:lisp-unit
:str
:uiop
:cl-fad
:cl-ppcre
:local-time
:iterate
:clsql-sqlite3)
:description "An NNTP server for a circle of friends."
:depends-on (:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon
:filesystem-utils)
:components ((:file "loop")))

270
loop.lisp
View file

@ -1,14 +1,8 @@
;;; -*- mode: LISP; syntax: COMMON-LISP; package: LOOP; -*-
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload
'(:lisp-unit
:str
:uiop
:cl-fad
:cl-ppcre
:local-time
:iterate
:clsql-sqlite3)
'(:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon
:filesystem-utils)
:silent t))
(clsql:enable-sql-reader-syntax)
@ -16,11 +10,109 @@
(defpackage #:loop
(:use :common-lisp :local-time)
(:import-from :lisp-unit define-test)
(:import-from :iterate iter)
(:import-from :org.shirakumo.filesystem-utils
directory-p list-directories list-files)
(:export :main))
(in-package #:loop)
(defun cli/command ()
(clingon:make-command
:name "loop"
:description "An NNTP server for a circle of friends."
:version "0.1"
:authors '("Circling Skies <loop@antartida.xyz>")
:license "GPL v3"
:options (cli/options)
:handler #'cli/main))
(defun cli/options ()
(list
(clingon:make-option
:string
:description "<username> <invited-by> creates a new account"
:long-name "create-account"
:key :create-account)
(clingon:make-option
:string
:description "<username> <new-password> changes password"
:long-name "change-passwd"
:key :change-passwd)
(clingon:make-option
:flag
:description "lists accounts"
:short-name #\l
:long-name "list-accounts"
:key :list-accounts)
(clingon:make-option
:flag
:description "runs NNTP server reading from stdout"
:short-name #\s
:long-name "server"
:key :server)
(clingon:make-option
:flag
:description "run a REPL on port 4006"
:short-name #\r
:long-name "repl"
:key :repl)
(clingon:make-option
:flag
:description "turn on debug logging on stderr"
:long-name "logging"
:key :logging)))
(defun cli/list-accounts ()
(println (str:join (crlf-string) (list-users))))
(defun cli/create-account (username args)
(let ((invited-by (car args)))
(cond ((null invited-by)
(println "Must specify who invites the new account."))
((get-account username)
(println "Username account ``~a'' already exists." username))
((not (get-account invited-by))
(println "Invited-by account ``~a'' doesn't exist." invited-by))
(t
(multiple-value-bind (okay? pass-or-error) (new-account! username invited-by)
(if okay?
(progn (println "Okay, account ``~a'' created with password ``~a''."
username pass-or-error)
(notify-user-created username))
(println "Sorry, ~a." pass-or-error)))))))
(defun cli/change-passwd (username args)
(let* ((random-passwd (random-string 6))
(given-passwd (car args))
(new-passwd (or given-passwd random-passwd)))
(if (not (get-account change-passwd-account))
(println "No such account ``~a''." change-passwd-account)
(multiple-value-bind (okay? problem) (change-passwd! change-passwd-account new-passwd)
(if okay?
(println "Okay, account ~a now has password ``~a''." change-passwd-account new-passwd)
(println "Sorry, could not change password: ~a." problem))))))
(defvar *debug* nil)
(defun cli/main (cmd)
(read-accounts!)
(connect-index! "message-id.db")
(create-index!)
(let ((args (clingon:command-arguments cmd))
(repl (clingon:getopt cmd :repl))
(server (clingon:getopt cmd :server))
(ca (clingon:getopt cmd :create-account))
(change-passwd-account (clingon:getopt cmd :change-passwd))
(list-accounts (clingon:getopt cmd :list-accounts))
(logging (clingon:getopt cmd :logging)))
(setf *debug* logging)
(when list-accounts
(cli/list-accounts))
(when ca
(cli/create-account ca args))
(when change-passwd-account
(cli/change-passwd change-passwd-account args))
(when repl
(stderr "Running a REPL on localhost:4006...~%"))
(when server
(server-start))))
(defun remove-inactive-users! ()
(loop for u in *accounts* do
(let ((username (account-username u)))
@ -45,21 +137,19 @@
(fmt "disappeared for over ~a months"
*months-inactive-allowed*))
(format t "Locked ~a due to long-time-no-see.~%" username))))))
(defun remove-account! (username)
(loop for u in *accounts* do
(delete-if #'(lambda (x) (equal x username)) (account-friends u)))
(delete-if #'(lambda (x) (equal username (account-username x))) *accounts*))
(setf (account-friends u)
(delete username (account-friends u) :test #'equal)))
(setf *accounts*
(delete-if #'(lambda (a) (equal (account-username a) username))
*accounts*)))
(defun lock-account! (username why)
(let ((u (get-account username)))
(setf (account-pass-locked u) (account-pass u))
(setf (account-pass u) "locked")
(setf (account-pass-locked-why u) why)))
(defun remove-friend (username friend)
(remove-if #'(lambda (x) (equal x friend))
(account-friends (get-account username))))
(defparameter *months-inactive-allowed* 3)
(defparameter *months-never-logged-in* 1)
@ -132,7 +222,7 @@
(clsql:execute-command "create unique index if not exists idx_id_1
on indices (id)"))
(defun remake-index! ()
(defun drop-create-index! ()
(clsql:execute-command "drop table if exists indices")
(create-index!))
(defun insert-index (m g i)
@ -163,15 +253,22 @@
(defun plural (v suffix)
(if (> v 1) "s" ""))
(defun debug? () nil)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun fmt (cstr &rest args)
(apply #'format nil (list* cstr args))))
(defun out (stream &rest args)
(apply #'format (cons stream args)))
(defun stderr (&rest args)
(when (debug?)
(apply #'format (cons *error-output* args))))
(when *debug*
(apply #'out (cons *error-output* args))))
(defun stdout (&rest args)
(apply #'out (list* *standard-output* args)))
(defun println (&rest args)
(apply #'out (list* *standard-output* (str:concat (car args) "~%") (cdr args))))
(defun enumerate (ls &optional (first-index 0))
(loop for e in ls and i from first-index
@ -366,14 +463,15 @@
(defun request-quit? (r) (and r (string= 'quit (request-verb r))))
(defun response-quit? (r) (and r (request-quit? (response-request r))))
(defun main ()
(send-banner!)
(defun server-start ()
(set-up-tables!)
(read-accounts!)
(connect-index! "message-id.db")
(create-index!)
(send-banner!)
(main-loop))
(defun main ()
(let ((app (cli/command)))
(clingon:run app)))
(defun send-banner! ()
(send-response!
(make-response :code 200 :data "Welcome! Say ``help'' for a menu.")))
@ -448,11 +546,15 @@
(read-file-raw (format nil "~a/~a" g i))))
(defun read-file-raw (path)
(let* ((size (sb-posix:stat-size (sb-posix:stat path)))
(a (make-array size)))
(with-open-file (in path :element-type '(unsigned-byte 8))
(read-sequence a in)
a)))
(with-open-file
(in path
:element-type '(unsigned-byte 8)
:if-does-not-exist nil)
(when in
(let* ((size (sb-posix:stat-size (sb-posix:stat path)))
(a (make-array size)))
(read-sequence a in)
a))))
(defun fetch-body (g i)
(article-body (parse-article (fetch-article g i))))
@ -534,19 +636,21 @@
(defun body-response (r g i)
(typical-cmd-response 222 r g i #'(lambda (a) (encode-body (article-body (parse-article a))))))
(defun typical-cmd-response (code r g i get-data)
(let ((a (handler-case (fetch-article g i)
(sb-posix:syscall-error (c)
(make-response :code 400 :request r
:data (format nil "article ~a/~a: ~a" g i c)))
(sb-ext:file-does-not-exist (c)
(declare (ignore c))
(make-response :code 400 :request r
:data (format nil "article ~a/~a does not exist" g i))))))
(cond ((typep a 'response) a)
(t (prepend-response-with
(format nil "~a ~a" i (extract-mid a))
(make-response :multi-line 'yes :code code
:request r :data (funcall get-data a)))))))
(handler-case
(let ((a (fetch-article g i)))
(cond ((null a)
(make-response
:code 400 :request r
:data (format nil "article ~a/~a does not exist" g i)))
(t
(prepend-response-with
(format nil "~a ~a" i (extract-mid a))
(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)))))
(defun cmd-next (r)
(with-auth
(let ((g (client-group *client*))
@ -627,10 +731,10 @@
(defun group? (g)
(in-groups
(cl-fad:directory-exists-p g)))
(directory-p g)))
(defun xgroup? (g)
(cl-fad:directory-exists-p g))
(directory-p g))
(defun set-group! (g)
(setf (client-group *client*) g))
@ -675,12 +779,28 @@
(defun article-ready? (path)
(not (temporary-article? path)))
(defun loop-directory* (directory &rest args &key &allow-other-keys)
#+allegro (apply #'directory directory :directories-are-files NIL :follow-symbolic-links NIL args)
#+(or clozure digitool) (apply #'directory directory :follow-links NIL args)
#+clisp (apply #'directory directory :circle T :if-does-not-exist :ignore args)
#+(or cmucl scl) (apply #'directory directory :follow-links NIL :truenamep NIL args)
#+lispworks (apply #'directory directory :link-transparency NIL args)
#+sbcl (apply #'directory directory :resolve-symlinks NIL args)
#-(or allegro clozure digitool clisp cmucl scl lispworks sbcl)
(apply #'directory directory args))
(defun loop-list-files (directory)
(let ((directory (pathname-utils:to-directory directory)))
(let* ((directory (pathname-utils:pathname* directory))
(entries (ignore-errors (loop-directory* (merge-pathnames pathname-utils:*wild-file* directory)))))
(remove-if #'directory-p entries))))
(defun get-articles (g &optional from to)
(in-groups ;; We might want to optimize this some day. Most likely,
;; though, we'll not be using directories. That's a
;; problem to be studied.
(let ((as (articles->integers
(remove-if #'temporary-article? (cl-fad:list-directory g)))))
(remove-if #'temporary-article? (loop-list-files (truename g))))))
(sort (remove-if-not
#'(lambda (x) (between? x (or from x) (or to x)))
as)
@ -700,8 +820,29 @@
(parse-integer (basename (uiop:unix-namestring g)))))
ls)))
(defun loop-list-directories (directory)
(let ((directory (pathname-utils:to-directory directory)))
(let* (#-(or abcl cormanlisp genera xcl)
(wild (merge-pathnames
#-(or abcl allegro cmucl lispworks sbcl scl xcl)
pathname-utils:*wild-directory*
#+(or abcl allegro cmucl lispworks sbcl scl xcl) "*.*"
directory))
(dirs
#+(or abcl xcl) (system:list-directory directory)
#+cormanlisp (cl::directory-subdirs directory)
#+genera (handler-case (loop for (p . k) in (fs:directory-list directory)
when (eql :directory k) collect p)
(fs:directory-not-found () nil))
#+clozure (ignore-errors (directory* wild :directories T :files NIL))
#+mcl (ignore-errors (directory* wild :directories T))
#-(or abcl xcl cormanlisp genera clozure mcl) (loop-directory* wild)))
(loop for path in dirs
when (directory-p path)
collect (pathname-utils:force-directory path)))))
(defun list-groups ()
(let ((groups (in-groups (cl-fad:list-directory "."))))
(let ((groups (in-groups (loop-list-directories (truename ".")))))
(sort (mapcar #'(lambda (g) (basename (uiop:unix-namestring g))) groups)
#'string-lessp)))
@ -852,9 +993,12 @@
(with-open-file
(s name
:direction :output
:if-exists :error ;; an atomic operation
:if-does-not-exist :create))
;(format t "save-article-try: ~a~%" name)
:if-exists nil ;; an atomic operation
:if-does-not-exist :create)
(when (null s)
(progn
(stderr "warning: save-article-try: ~a exists~%" name)
(return-from save-article-try 'name-exists))))
(with-open-file
(s tmp
:direction :output
@ -866,18 +1010,8 @@
(defun save-article-insist (g name a message-id)
(loop for name from name do
(in-dir (format nil "groups/~a/" g)
(handler-case
(save-article-try name a)
(sb-ext:file-exists ()
;; We might want to log the fact.
;(format t "name ~a already exists...~%" name)
)
(:no-error (new before after) ;; the return values from return-file
(declare (ignore new before after))
(return (values name (insert-index message-id g (fmt "~a" name)))))))))
(defun get-next-article-name (g)
(format nil "~a" (get-next-article-id g)))
(when (not (eql 'name-exists (save-article-try name a)))
(return (values name (insert-index message-id g (fmt "~a" name))))))))
(defun get-next-article-id (g)
(multiple-value-bind (low high len) (group-high-low g)
@ -954,7 +1088,7 @@
(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)
(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))
@ -975,7 +1109,7 @@
(setq *accounts* (read s))))
*accounts*)
(defun new-account! (username)
(defun new-account! (username invited-by)
(let* ((u (str:upcase username))
(p (random-string 6))
(a (make-account :username u
@ -983,8 +1117,8 @@
:creation (get-universal-time))))
(if (get-account u)
(values nil (fmt "account ~a already exists" u))
(let ((c (get-account (client-username *client*))))
(push u (account-friends c))
(progn
(push u (account-friends (get-account invited-by)))
(push a *accounts*)
(write-accounts!)
(values (str:upcase username) p)))))
@ -1190,5 +1324,5 @@
(insert-index m g i)))))
(defun remake-index-from-fs ()
(remake-index!)
(drop-create-index!)
(index-from-fs!))

506
loop.nw
View file

@ -7,7 +7,7 @@
\usepackage[T1]{fontenc}
\usepackage[utf8]{inputenc}
\usepackage{csquotes}
\usepackage[brazil]{babel}
\usepackage{babel}
\usepackage{etoolbox}
\AtBeginEnvironment{quote}{\small}
@ -16,14 +16,14 @@
%% \usepackage[backend=biber]{biblatex}
%% \addbibresource{refs.bib}
%% \renewcommand{\cite}{\parencite}
\usepackage[hyperref]{xcolor}
% \usepackage[hyperref]{xcolor}
\usepackage[colorlinks=true,citecolor=]{hyperref} % linkcolor=red
\usepackage{amsmath,amsthm,amssymb}
\allowdisplaybreaks
\usepackage{lmodern}
\usepackage{noweb}
\noweboptions{brazil,longchunks,smallcode}
\noweboptions{longchunks,smallcode}
\DeclareMathOperator{\mdc}{mdc}
\DeclareMathOperator{\gcdext}{gcdext}
\DeclareMathOperator{\remainder}{remainder}
@ -359,6 +359,18 @@ way, they work together. And \lp\ handles only a text stream, which
is why it's so easy to connect a keyboard to it and interact with it
through the command line as illustrated in Section~\ref{sec:design}.
\section{The description of the package}
<<Description>>=
An NNTP server for a circle of friends.
@
<<Version>>=
0.1
@
These chunks are used in [[loop.asd]].
\section{The representation of a client}
How do we represent a client? A client is typically reading a group
@ -557,19 +569,143 @@ itself---so we can cascade actions based on a user's request.
(defun request-quit? (r) (and r (string= 'quit (request-verb r))))
(defun response-quit? (r) (and r (request-quit? (response-request r))))
(defun main ()
(send-banner!)
(defun server-start ()
(set-up-tables!)
(read-accounts!)
(connect-index! "message-id.db")
(create-index!)
(send-banner!)
(main-loop))
(defun main ()
(let ((app (cli/command)))
(clingon:run app)))
(defun send-banner! ()
(send-response!
(make-response :code 200 :data "Welcome! Say ``help'' for a menu.")))
@ %def main main-loop
\section{Command-line parsing}
We're using the clingon library as per Vincent Dardel suggestion in
``The Common Lisp Cookbook''. (Thanks, Vincent!) 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.
<<Command-line parsing>>=
(defun cli/command ()
(clingon:make-command
:name "loop"
:description "<<Description>>"
:version "<<Version>>"
:authors '("Circling Skies <loop@antartida.xyz>")
:license "GPL v3"
:options (cli/options)
:handler #'cli/main))
(defun cli/options ()
(list
(clingon:make-option
:string
:description "<username> <invited-by> creates a new account"
:long-name "create-account"
:key :create-account)
(clingon:make-option
:string
:description "<username> <new-password> changes password"
:long-name "change-passwd"
:key :change-passwd)
(clingon:make-option
:flag
:description "lists accounts"
:short-name #\l
:long-name "list-accounts"
:key :list-accounts)
(clingon:make-option
:flag
:description "runs NNTP server reading from stdout"
:short-name #\s
:long-name "server"
:key :server)
(clingon:make-option
:flag
:description "run a REPL on port 4006"
:short-name #\r
:long-name "repl"
:key :repl)
(clingon:make-option
:flag
:description "turn on debug logging on stderr"
:long-name "logging"
:key :logging)))
@
The command-line options form a language. The user specifies
everything he wants with flags. If he wants nothing, for instance, he
specifies nothing and then nothing happens. XXX: I'd like to have a
default action (which would be running the server) that is invoked by
default if none of the other options would run. But I don't know how
to do that yet.
<<Command-line parsing>>=
(defun cli/list-accounts ()
(println (str:join (crlf-string) (list-users))))
(defun cli/create-account (username args)
(let ((invited-by (car args)))
(cond ((null invited-by)
(println "Must specify who invites the new account."))
((get-account username)
(println "Username account ``~a'' already exists." username))
((not (get-account invited-by))
(println "Invited-by account ``~a'' doesn't exist." invited-by))
(t
(multiple-value-bind (okay? pass-or-error) (new-account! username invited-by)
(if okay?
(progn (println "Okay, account ``~a'' created with password ``~a''."
username pass-or-error)
(notify-user-created username))
(println "Sorry, ~a." pass-or-error)))))))
(defun cli/change-passwd (username args)
(let* ((random-passwd (random-string 6))
(given-passwd (car args))
(new-passwd (or given-passwd random-passwd)))
(if (not (get-account change-passwd-account))
(println "No such account ``~a''." change-passwd-account)
(multiple-value-bind (okay? problem) (change-passwd! change-passwd-account new-passwd)
(if okay?
(println "Okay, account ~a now has password ``~a''." change-passwd-account new-passwd)
(println "Sorry, could not change password: ~a." problem))))))
@
Now let's write the main procedure in command-line parsing.
<<Command-line parsing>>=
(defvar *debug* nil)
(defun cli/main (cmd)
(read-accounts!)
(connect-index! "message-id.db")
(create-index!)
(let ((args (clingon:command-arguments cmd))
(repl (clingon:getopt cmd :repl))
(server (clingon:getopt cmd :server))
(ca (clingon:getopt cmd :create-account))
(change-passwd-account (clingon:getopt cmd :change-passwd))
(list-accounts (clingon:getopt cmd :list-accounts))
(logging (clingon:getopt cmd :logging)))
(setf *debug* logging)
(when list-accounts
(cli/list-accounts))
(when ca
(cli/create-account ca args))
(when change-passwd-account
(cli/change-passwd change-passwd-account args))
(when repl
(stderr "Running a REPL on localhost:4006...~%"))
(when server
(server-start))))
@ %def cli/options cli/command
\section{The request dispatching mechanism}
Dispatching requests means consuming one and invoking the correct
@ -681,11 +817,15 @@ interpreting such bytes. That's why we call [[read-sequence]] here.
(read-file-raw (format nil "~a/~a" g i))))
(defun read-file-raw (path)
(let* ((size (sb-posix:stat-size (sb-posix:stat path)))
(a (make-array size)))
(with-open-file (in path :element-type '(unsigned-byte 8))
(read-sequence a in)
a)))
(with-open-file
(in path
:element-type '(unsigned-byte 8)
:if-does-not-exist nil)
(when in
(let* ((size (sb-posix:stat-size (sb-posix:stat path)))
(a (make-array size)))
(read-sequence a in)
a))))
(defun fetch-body (g i)
(article-body (parse-article (fetch-article g i))))
@ -728,7 +868,8 @@ Lisp offers me [[labels]], but [[labels]] don't seem so helpful when
I'm at the REPL. When I use [[defun]], I'm able to always invoke the
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.} %% TODO
reason to think we're doing to debug it.} XXX: replace menu with
[[loop]].
<<Help command>>=
(defun cmd-help (r)
@ -803,16 +944,10 @@ Syntax error. Say ``authinfo USER /your-name/'' then ``authinfo PASS /your-pass/
\subsection{{\tt CREATE-ACCOUNT}}
We allow authenticated members to invite their friends.
%% A propósito, estamos removendo a conta {\tt ROOT} de exibição. O que
%% significa que {\tt ROOT} não nem mesmo se conectar ao \Lp. Se
%% desejarmos que {\tt ROOT} se conecte, talvez a gente possa fazer
%% código especialmente pra gerenciar a conta dele. Fazemos assim pra
%% não permitir que usuários tenham qualquer chance de
%%
%% (remove-if #'(lambda (u) (equal "ROOT" (account-username u)))
%% (read s))
We allow authenticated members to invite their friends. Notice that
we're not doing any kind of checking on the username. XXX: take a
look at how we verify group names match a certain regex and apply the
same check here.
<<Command create-account>>=
(defun cmd-create-account (r)
@ -820,7 +955,7 @@ We allow authenticated members to invite their friends.
(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)
(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))
@ -841,7 +976,7 @@ We allow authenticated members to invite their friends.
(setq *accounts* (read s))))
*accounts*)
(defun new-account! (username)
(defun new-account! (username invited-by)
(let* ((u (str:upcase username))
(p (random-string 6))
(a (make-account :username u
@ -849,12 +984,12 @@ We allow authenticated members to invite their friends.
:creation (get-universal-time))))
(if (get-account u)
(values nil (fmt "account ~a already exists" u))
(let ((c (get-account (client-username *client*))))
(push u (account-friends c))
(progn
(push u (account-friends (get-account invited-by)))
(push a *accounts*)
(write-accounts!)
(values (str:upcase username) p)))))
@ %def CREATE-ACCOUNT
@ %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
@ -1094,12 +1229,28 @@ even cache the overview of the group.) %% TODO
(defun article-ready? (path)
(not (temporary-article? path)))
(defun loop-directory* (directory &rest args &key &allow-other-keys)
#+allegro (apply #'directory directory :directories-are-files NIL :follow-symbolic-links NIL args)
#+(or clozure digitool) (apply #'directory directory :follow-links NIL args)
#+clisp (apply #'directory directory :circle T :if-does-not-exist :ignore args)
#+(or cmucl scl) (apply #'directory directory :follow-links NIL :truenamep NIL args)
#+lispworks (apply #'directory directory :link-transparency NIL args)
#+sbcl (apply #'directory directory :resolve-symlinks NIL args)
#-(or allegro clozure digitool clisp cmucl scl lispworks sbcl)
(apply #'directory directory args))
(defun loop-list-files (directory)
(let ((directory (pathname-utils:to-directory directory)))
(let* ((directory (pathname-utils:pathname* directory))
(entries (ignore-errors (loop-directory* (merge-pathnames pathname-utils:*wild-file* directory)))))
(remove-if #'directory-p entries))))
(defun get-articles (g &optional from to)
(in-groups ;; We might want to optimize this some day. Most likely,
;; though, we'll not be using directories. That's a
;; problem to be studied.
(let ((as (articles->integers
(remove-if #'temporary-article? (cl-fad:list-directory g)))))
(remove-if #'temporary-article? (loop-list-files (truename g))))))
(sort (remove-if-not
#'(lambda (x) (between? x (or from x) (or to x)))
as)
@ -1119,8 +1270,29 @@ even cache the overview of the group.) %% TODO
(parse-integer (basename (uiop:unix-namestring g)))))
ls)))
(defun loop-list-directories (directory)
(let ((directory (pathname-utils:to-directory directory)))
(let* (#-(or abcl cormanlisp genera xcl)
(wild (merge-pathnames
#-(or abcl allegro cmucl lispworks sbcl scl xcl)
pathname-utils:*wild-directory*
#+(or abcl allegro cmucl lispworks sbcl scl xcl) "*.*"
directory))
(dirs
#+(or abcl xcl) (system:list-directory directory)
#+cormanlisp (cl::directory-subdirs directory)
#+genera (handler-case (loop for (p . k) in (fs:directory-list directory)
when (eql :directory k) collect p)
(fs:directory-not-found () nil))
#+clozure (ignore-errors (directory* wild :directories T :files NIL))
#+mcl (ignore-errors (directory* wild :directories T))
#-(or abcl xcl cormanlisp genera clozure mcl) (loop-directory* wild)))
(loop for path in dirs
when (directory-p path)
collect (pathname-utils:force-directory path)))))
(defun list-groups ()
(let ((groups (in-groups (cl-fad:list-directory "."))))
(let ((groups (in-groups (loop-list-directories (truename ".")))))
(sort (mapcar #'(lambda (g) (basename (uiop:unix-namestring g))) groups)
#'string-lessp)))
@ -1157,10 +1329,10 @@ We just need to verify if the group exists and modify [[*client*]].
(defun group? (g)
(in-groups
(cl-fad:directory-exists-p g)))
(directory-p g)))
(defun xgroup? (g)
(cl-fad:directory-exists-p g))
(directory-p g))
(defun set-group! (g)
(setf (client-group *client*) g))
@ -1214,27 +1386,39 @@ Section~\ref{sec:index} for the implementation of the index.
(typical-cmd-response 222 r g i #'(lambda (a) (encode-body (article-body (parse-article a))))))
@
When we process such commands, it's typical that we need to verify the
existence of files {\em et cetera}. The procedure that might throw
[[sb-posix:syscall-error]] is [[sb-posix:stat-size]], which we use to
know how many bytes are there in an article, a necessary task in
producing the \verb|OVERVIEW|.
In processing such commands, we need to verify the existence of files
{\em et cetera}. The procedure [[fetch-article]] returns [[nil]] when
the article requested doesn't exist and it throws
[[sb-posix:syscall-error]] due to [[sb-posix:stat-size]], which we
need to find the size of the article. We need to know the file size
not only to allocate an array at the right size, but also because we
must provide the size when producing the \verb|OVERVIEW|. If a
problem such as [[sb-posix:syscall-error]] appears, we just inform the
client and terminate the request---nothing else to do.
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.
<<Commands head, body, article>>=
(defun typical-cmd-response (code r g i get-data)
(let ((a (handler-case (fetch-article g i)
(sb-posix:syscall-error (c)
(make-response :code 400 :request r
:data (format nil "article ~a/~a: ~a" g i c)))
(sb-ext:file-does-not-exist (c)
(declare (ignore c))
(make-response :code 400 :request r
:data (format nil "article ~a/~a does not exist" g i))))))
(cond ((typep a 'response) a)
(t (prepend-response-with
(format nil "~a ~a" i (extract-mid a))
(make-response :multi-line 'yes :code code
:request r :data (funcall get-data a)))))))
(handler-case
(let ((a (fetch-article g i)))
(cond ((null a)
(make-response
:code 400 :request r
:data (format nil "article ~a/~a does not exist" g i)))
(t
(prepend-response-with
(format nil "~a ~a" i (extract-mid a))
(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)))))
@ %def typical-cmd-response
The command \verb|NEXT| has a slight different semantics.
@ -1506,10 +1690,17 @@ user to either remove the invalid group of type it up properly.
(setf (account-last-post u) (get-universal-time))))
@ %def update-last-post-date!
If [[save-article-try]] returns [[NIL]], then [[probe-file]]
has found an article with name [[name-try]], that is, the procedure
is only successful if [[name-try]] is not yet taken and the writing
takes place successfully.
The job of [[save-article-try]] is to atomically allocate an article
name in a group. The atomicity is achieved with [[:if-exists]] in the
[[with-open-file]] macro. When [[if:-exists]] is used, the {\tt open}
system call uses the flag \verb|O_EXCL|, given us an atomic operation.
So, the first [[with-open-file]] allocates the name. If successful,
we take our time writing the article to the temporary file and we
atomically rename it at the end. We should close [[name]] before
trying to [[rename-no-extention]]---on UNIX systems, renaming an open
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>>=
(defun rename-no-extension (old new)
@ -1521,9 +1712,12 @@ takes place successfully.
(with-open-file
(s name
:direction :output
:if-exists :error ;; an atomic operation
:if-does-not-exist :create))
;(format t "save-article-try: ~a~%" name)
:if-exists nil ;; an atomic operation
:if-does-not-exist :create)
(when (null s)
(progn
(stderr "warning: save-article-try: ~a exists~%" name)
(return-from save-article-try 'name-exists))))
(with-open-file
(s tmp
:direction :output
@ -1532,42 +1726,25 @@ takes place successfully.
:element-type '(unsigned-byte 8))
(write-sequence bs s))
(rename-no-extension tmp name)))
@
@ %def save-article-try
The procedure [[save-article-insist]] can return [[NIL]] and still
have perfectly done its job: it's possible for [[insert-index]] to
return [[NIL]] because [[message-id]] may already exist in the index,
but that may be no error---for example, when cross-posting. The
strategy is to write the article using [[name-try]]. If it's not
possible to write it because of a [[sb-ext:file-exists]] condition,
then we try the new name {\tt (1+ name-try)} and we repeat these
attempts until we make it. If other condition appears, we let it
propagate up the stack. If we get to the second [[let]], it's because
the article has been saved successfully, so we finish with whatever it
is that [[insert-index-or-log-failure]] must do.
The procedure [[save-article-insist]] insists on calling
[[save-article-try]] until it finds an article name that has not been
allocated. Notice that the argument [[name]] is an integer, so
[[name]] is incremented at each iteration.
<<Command post>>=
(defun save-article-insist (g name a message-id)
(loop for name from name do
(in-dir (format nil "groups/~a/" g)
(handler-case
(save-article-try name a)
(sb-ext:file-exists ()
;; We might want to log the fact.
;(format t "name ~a already exists...~%" name)
)
(:no-error (new before after) ;; the return values from return-file
(declare (ignore new before after))
(return (values name (insert-index message-id g (fmt "~a" name)))))))))
(defun get-next-article-name (g)
(format nil "~a" (get-next-article-id g)))
(when (not (eql 'name-exists (save-article-try name a)))
(return (values name (insert-index message-id g (fmt "~a" name))))))))
(defun get-next-article-id (g)
(multiple-value-bind (low high len) (group-high-low g)
(declare (ignore low len))
(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. It's also the slowest. What I think
@ -1860,10 +2037,10 @@ specify anything.
(clsql:execute-command "create unique index if not exists idx_id_1
on indices (id)"))
(defun remake-index! ()
(defun drop-create-index! ()
(clsql:execute-command "drop table if exists indices")
(create-index!))
@ %def create-index! remake-index! connect-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]].
@ -1986,19 +2163,23 @@ we need to index it.
(insert-index m g i)))))
(defun remake-index-from-fs ()
(remake-index!)
(drop-create-index!)
(index-from-fs!))
@
Here's a program to build the index from a UNIX shell.
<<build-index-from-fs.lisp>>=
(load "~/.sbclrc")
#-quicklisp
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
(user-homedir-pathname))))
(when (probe-file quicklisp-init)
(load quicklisp-init)))
(ql:quickload :loop :silent t)
(in-package #:loop)
(connect-index! "message-id.db")
(remake-index!)
(index-from-fs)
(drop-create-index!)
(index-from-fs!)
(format t "Index built.~%")
@
@ -2019,21 +2200,25 @@ Index built.
\section{Deletion and locking of inactive accounts}\label{sec:inactive-users}
In [[remove-friend]], note that [[username]] is the account name and
[[friend]] is the name of the account being removed. Notice as well
that we only know who invited the person after we can get a hold of
the account in [[accounts.lisp]]. This means we must scan each
account to delete an account---we can't delete an account and still
leave the account as someone's friend.
XXX: remove this paragraph from here; present the program first and
then talk about it. In [[remove-friend]], note that [[username]] is
the account name and [[friend]] is the name of the account being
removed. Notice as well that we only know who invited the person
after we can get a hold of the account in [[accounts.lisp]]. This
means we must scan each account to delete an account---we can't delete
an account and still leave the account as someone's friend.
The program [[cron-remove-inactive-users.lisp]] can be executed every
day at midnight, say.
<<cron-remove-inactive-users.lisp>>=
(load "~/.sbclrc")
#-quicklisp
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
(user-homedir-pathname))))
(when (probe-file quicklisp-init)
(load quicklisp-init)))
(ql:quickload :loop :silent t)
(in-package #:loop)
;; (format t *default-pathname-defaults*)
(read-accounts!)
(connect-index! "message-id.db")
(remove-inactive-users!)
@ -2069,22 +2254,33 @@ with [[setf]]. %% TODO
(fmt "disappeared for over ~a months"
*months-inactive-allowed*))
(format t "Locked ~a due to long-time-no-see.~%" username))))))
@ %def remove-inactive-users!
To remove an account, we need to first remove the username (to be
removed) from anyone's list of friends. So, this involves scanning
the entire list of accounts. Also, notice that delete ``may modify
{\em sequence}''. More importantly is to understand tha we really
must {\tt setf} the return, otherwise we might find the deletion did
not take effect---for example, when deleting the first element of a
list. (This deserves a better explanation, but if you know how linked
lists are implemented in C, say, then you're likely well aware of how
it works.)
<<How to remove inactive users>>=
(defun remove-account! (username)
(loop for u in *accounts* do
(delete-if #'(lambda (x) (equal x username)) (account-friends u)))
(delete-if #'(lambda (x) (equal username (account-username x))) *accounts*))
(setf (account-friends u)
(delete username (account-friends u) :test #'equal)))
(setf *accounts*
(delete-if #'(lambda (a) (equal (account-username a) username))
*accounts*)))
(defun lock-account! (username why)
(let ((u (get-account username)))
(setf (account-pass-locked u) (account-pass u))
(setf (account-pass u) "locked")
(setf (account-pass-locked-why u) why)))
(defun remove-friend (username friend)
(remove-if #'(lambda (x) (equal x friend))
(account-friends (get-account username))))
@ %def remove-account! remove-friend
@ %def remove-account!
Accounts that do not have a creation date up until today---Tue Sep 17
21:37:18 ESAST 2024---will have its creation dates migrated to the
@ -2108,7 +2304,11 @@ New system administrators of \Lp\ will never need to run this.
Here's a program to run the migration in a UNIX shell.
<<migrate-add-creation-date.lisp>>=
(load "~/.sbclrc")
#-quicklisp
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
(user-homedir-pathname))))
(when (probe-file quicklisp-init)
(load quicklisp-init)))
(ql:quickload :loop :silent t)
(in-package #:loop)
(migrate-add-creation-and-post-date!)
@ -2240,15 +2440,22 @@ means 2 bytes. So our conversion is just removing the first byte.
(defun plural (v suffix)
(if (> v 1) "s" ""))
(defun debug? () nil)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun fmt (cstr &rest args)
(apply #'format nil (list* cstr args))))
(defun out (stream &rest args)
(apply #'format (cons stream args)))
(defun stderr (&rest args)
(when (debug?)
(apply #'format (cons *error-output* args))))
(when *debug*
(apply #'out (cons *error-output* args))))
(defun stdout (&rest args)
(apply #'out (list* *standard-output* args)))
(defun println (&rest args)
(apply #'out (list* *standard-output* (str:concat (car args) "~%") (cdr args))))
(defun enumerate (ls &optional (first-index 0))
(loop for e in ls and i from first-index
@ -2320,18 +2527,28 @@ the code.
\section{How to produce the binary executable}
Just say {\tt make exe} to your shell.
Just say {\tt make loop} to your shell.
<<build-exe.lisp>>=
(load "~/.sbclrc")
#-quicklisp
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
(user-homedir-pathname))))
(when (probe-file quicklisp-init)
(load quicklisp-init)))
(ql:quickload :loop :silent t)
(sb-ext:save-lisp-and-die #P"loop.exe"
(sb-ext:save-lisp-and-die #P"loop"
:toplevel #'loop:main
:executable t)
:executable t
:save-runtime-options t)
@
\section{How to update the remote server}\label{sec:live}
XXX: notice we don't include such targets in the [[Makefile]]
anymore. Now we use a [[Makefile.personal]] that we don't release
anymore. We may still keep this section as instruction, but we need
to update it to reflect the facts.
We automate here the process of updating and compilation of a new
version of \lp. It's certain that what we document here is specific
to a single UNIX system, but what's important is that you (dear
@ -2417,18 +2634,16 @@ variables in the chunks where it's used. But for someone reading
global variables at the top of the file. That's something to think
about.
<<List of packages to be loaded>>=
:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon
:filesystem-utils
@
<<loop.lisp>>=
;;; -*- mode: LISP; syntax: COMMON-LISP; package: LOOP; -*-
(eval-when (:compile-toplevel :load-toplevel :execute)
(ql:quickload
'(:lisp-unit
:str
:uiop
:cl-fad
:cl-ppcre
:local-time
:iterate
:clsql-sqlite3)
'(<<List of packages to be loaded>>)
:silent t))
(clsql:enable-sql-reader-syntax)
@ -2436,11 +2651,13 @@ about.
(defpackage #:loop
(:use :common-lisp :local-time)
(:import-from :lisp-unit define-test)
(:import-from :iterate iter)
(:import-from :org.shirakumo.filesystem-utils
directory-p list-directories list-files)
(:export :main))
(in-package #:loop)
<<Command-line parsing>>
<<How to remove inactive users>>
<<How to enumerate inactive accounts>>
<<How to migrate accounts without a creation date>>
@ -2487,37 +2704,58 @@ about.
<<loop.asd>>=
;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*-
(asdf:defsystem :loop
:version "0.0.1"
:description "An NNTP server for a group of friends."
:depends-on (:lisp-unit :str :uiop :cl-fad :cl-ppcre)
:version "<<Version>>"
:description "<<Description>>"
:depends-on (<<List of packages to be loaded>>)
:components ((:file "loop")))
@ %def :loop
@ %def :loop loop.asd
\section{The UNIX service}
XXX: this section should be informative only. We're going to suggest
users how to run the system. We may provide a [[make install]] target
that runs things the way we do, but this should be optional. Idea:
instead of hard coding a path to the service, make it {\tt conf-home}
or {\tt conf-service}.
The installation is as follows. You clone the repo to your
local-projects, then run make build. This builds the executable. You
edit conf-home to choose your install directory. Then you say make
install which copies loop, accounts.lisp, the scripts and the service
directory. It is now the syadmin duty to do ln -s ./svc to
/service/loop, which runs it. Let's see if we can pull that off.
We use the {\tt tcpserver} program by Daniel J. Bernstein from the
package \href{https://cr.yp.to/ucspi-tcp.html}{\tt ucspi-tcp}.
<<path to the service>>=
/home/dbastos/loop
@ %def
<<port number>>=
119
@ %def
<<run>>=
#!/bin/sh
home=`head -1 conf-home`
cd $home
exec 2>1&
echo loop
cd <<path to the service>>
exec <<path to the service>>/tcpserver -HR 0.0.0.0 <<port number>> <<path to the service>>/loop.exe
exec "$home"/tcpserver -HR 0.0.0.0 <<port number>> "$home"/loop
@ %def
How should you update the server if you modified the source-code? See
Section~\ref{sec:live}.
<<log-run>>=
#!/bin/sh
echo loop
exec /usr/bin/logger -i -t loop
@
\section{The writing process}
XXX: note to self. Targets [[make build]] and [[make install]] must
be completely non-dependent on noweb. Also, most users will not run
any web at all---they'll run noweb, so releasing {\tt any} use in the
Makefile makes no sense to users. I think we'll need to set up a
virtual machine to practice the use of real-world noweb for other
users. (Lots of work!)
The program {\tt latexmk} is iseful when I'm writing \LaTeX\ in
general, but to get the attention of {\tt latexmk} we need to rewrite
{\tt loop.tex}. So what I do while writing \lp\ is to have a

10
scripts/build-exe.lisp Normal file
View file

@ -0,0 +1,10 @@
#-quicklisp
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
(user-homedir-pathname))))
(when (probe-file quicklisp-init)
(load quicklisp-init)))
(ql:quickload :loop :silent t)
(sb-ext:save-lisp-and-die #P"loop"
:toplevel #'loop:main
:executable t
:save-runtime-options t)

11
scripts/build-index-from-fs.lisp Normal file
View file

@ -0,0 +1,11 @@
#-quicklisp
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
(user-homedir-pathname))))
(when (probe-file quicklisp-init)
(load quicklisp-init)))
(ql:quickload :loop :silent t)
(in-package #:loop)
(connect-index! "message-id.db")
(drop-create-index!)
(index-from-fs!)
(format t "Index built.~%")

11
scripts/cron-remove-inactive-users.lisp Normal file
View file

@ -0,0 +1,11 @@
#-quicklisp
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
(user-homedir-pathname))))
(when (probe-file quicklisp-init)
(load quicklisp-init)))
(ql:quickload :loop :silent t)
(in-package #:loop)
(read-accounts!)
(connect-index! "message-id.db")
(remove-inactive-users!)
(write-accounts!)

9
scripts/migrate-add-creation-date.lisp Normal file
View file

@ -0,0 +1,9 @@
#-quicklisp
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
(user-homedir-pathname))))
(when (probe-file quicklisp-init)
(load quicklisp-init)))
(ql:quickload :loop :silent t)
(in-package #:loop)
(migrate-add-creation-and-post-date!)
(format t "Accounts rewritten.~%")