Incorporates format-def, make-release into loop.nw.

It also includes scripts for formating Lisp code for people who will
read Lisp code directly.  It doesn't cost us much to organize the Lisp
output a bit.  In a similar spirit, I'm not including NOWEB as part of
the build process.  (Most users will not have NOWEB around to use it.)
So while the Makefile is pretty short because there's little to do,
Anyfile is the ANYWEB makefile.  ANYWEB is my modified, personal
version of NOWEB for Windows.  (The way I use this second makefile is
to make a shell alias called /amake/ that automatically invokes ``make
-f Anyfile'' for me.)

Anyfile

@@ -8,18 +8,32 @@ scripts/build-index-from-fs.lisp \
 scripts/cron-remove-inactive-users.lisp \
 scripts/migrate-add-creation-date.lisp
 
-loop.exe: scripts/build-exe.lisp loop.lisp loop.asd
+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
+loop.lisp: loop.nw format-def
-	./make-release $$(git log --oneline | head -1 | awk '{print $$1}') \
-           loop.nw > loop.tmp && mv loop.tmp loop.nw
 	(any tangle -Rloop.lisp < loop.nw | sh format-def | \
 		dos2unix > 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 || \
+		(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 || \
+		(rm make-release.tmp && exit 1)) && \
+		mv make-release.tmp make-release
+
+release: make-release
+	./make-release $$(git log --oneline | head -1 | awk '{print $$1}') \
+           loop.nw > loop.tmp && mv loop.tmp loop.nw
+
 loop.asd: loop.nw
 	(any tangle -Rloop.asd < loop.nw | dos2unix > loop-asd.tmp || \
 		(rm loop-asd.tmp && exit 1)) && \

README

@@ -6,10 +6,10 @@ LOOP is an NNTP server written in Common Lisp.
 
 We assume
 
-  - you run SBCL, Quicklisp and git installed
+  - you have SBCL, Quicklisp and git installed
   - you know how to use a TCP server such as 
       https://cr.yp.to/ucspi-tcp.html
-  - you know how to manage a daemon witha package such as
+  - you know how to manage a daemon with a package such as
       https://cr.yp.to/daemontools.html
 
 (*) How to install it
@@ -26,37 +26,13 @@ and say
   $ echo /path/to/loop/home > conf-home
   $ make install
 
-(*) 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.
-
 (*) Running LOOP
 
 First, try it out.
 
 $ cd /path/to/loop/home
-$ ./loop
+$ ./loop.exe
-200 Welcome! Say ``help'' for a menu.
+200 Welcome! I am LOOP 9575ac2. Say ``help'' for a menu.
 quit
 205 Good-bye.
 
@@ -72,19 +48,23 @@ 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
+we keep a tree of accounts.  So say
-your first account must be invited by the anonymous account.  So you
-can say
 
-  ./loop --create-account you anonymous
+  ./loop --create-account you root
 
-The anonymous account has no special power; it exists solely because
+to create YOU, your account.  The root account has no special power;
-the graph of accounts needs a root.
+it exists solely because a tree of accounts needs a root.  It's an
+account like any other, so you could use it yourself.  In that case,
+change its password:
+
+$ ./loop --change-passwd root <secret>
+Okay, account root now has password ``<secret>''.
 
 (*) How to expose LOOP to the network
 
-Run your TCP server of choice.  For instance, if you're using djb's
+Just run your TCP server of choice.  For instance, if you're using
-tcpserver and would like LOOP to listen on port 1024, tell your shell
+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
@@ -137,3 +117,27 @@ scripts/cron-remove-inactive-users.lisp.  Here's our crontab:
 
 $ crontab -l
 @daily cd /path/to/loop/home && sbcl --script scripts/cron-remove-inactive-users.lisp
+
+(*) 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.

accounts.lisp

@@ -1,9 +1,10 @@
 (#S(LOOP::ACCOUNT
-    :USERNAME "ANONYMOUS"
+    :USERNAME "ROOT"
-    :SEEN 3935609919
+    :SEEN 3943778307
     :LAST-POST NIL
     :FRIENDS NIL
-    :PASS NIL
+    :PASS #(166 101 164 89 32 66 47 157 65 126 72 103 239 220 79 184 160 74 31
+            63 255 31 160 126 153 142 134 247 247 162 122 227)
     :PASS-LOCKED NIL
     :PASS-LOCKED-WHY NIL
     :CREATION 3913066800))

format-def

@@ -4,24 +4,12 @@ usage()
   printf 'usage: %s [file.lisp]\n' $0
   exit 1
 }
-## The first program finds certain definitions and inserts a new blank
+
-## line *before* the definition.  Such action makes function
-## definitions separated by two blank lines in some cases.  We then
-## remove the excess with the second program.  Notice we need the -E
-## option because we're using the | metacharacter that is only
-## supported by popular sed programs with the -E option.  This
-## violates POSIX sed, but keep in mind that we only run this when
-## releasing the package.  This is a building tool, not part of the
-## service.
 sed -E '/^\(defun |\(defmacro /{
  i\
 
-}' $* | sed '/^[ \t]*$/{
+}' "$@" | \
+sed '/^[ \t]*$/{
    N
    /^[ \t]*\n$/D
 }'
-## We first find a blank line.  Then we say N to expand the pattern
-## space to include the next line.  Then we delete the *first* blank
-## line and not the second---that's what the D command does.  This
-## strategy is explained by Dale Dougherty and Arnold Robbins in ``sed
-## & awk'' second edition, pages 112--114.

loop.asd

@@ -1,6 +1,6 @@
 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*-
 (asdf:defsystem :LOOP
-  :version "9575ac2"
+  :version "a89e088"
   :description "An NNTP server for a circle of friends."
   :depends-on (:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon
                :filesystem-utils :ironclad/digest/sha256)

loop.lisp

@@ -9,7 +9,7 @@
 
 (defpackage #:loop
   (:use :common-lisp :local-time)
-  (:import-from :lisp-unit define-test)
+  (:import-from :lisp-unit define-test assert-true)
   (:import-from :org.shirakumo.filesystem-utils 
                 directory-p list-directories list-files)
   (:import-from :sb-sys interactive-interrupt)
@@ -17,19 +17,20 @@
 
 (in-package #:loop)
 
+(defparameter *debug* nil)
 (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)
-(defvar *default-database* nil)
+(defparameter *default-database* nil)
 (defstruct command fn verb description)
 (defparameter *commands-assoc* nil)
 (defstruct article headers body)
 (defparameter *months-inactive-allowed* 3)
 (defparameter *months-never-logged-in* 1)
-(defvar *debug* nil)
+(defparameter *enable-nntp-repl* t)
 
 (defun table-of-commands ()
   `(("GROUP" ,#'cmd-group "sets the current group") 
@@ -92,7 +93,7 @@
 (defun in-group-lambda (g fn) (in-dir g (funcall fn)))
 
 (defmacro in-group (g &rest body)
-  `(in-group-lambda ,(fmt "groups/~a/" g) (lambda () ,@body)))
+  `(in-group-lambda ,(fmt "groups/~a/" g) #'(lambda () ,@body)))
 
 (defmacro with-group (g r &rest body)
   (let ((g-var (gensym))
@@ -126,10 +127,24 @@
        (make-response :code 400 :data "You must authenticate first.")
        (progn ,@body)))
 
+(defun conforms-to? (s re &optional error-msg)
+  "Does string S conform to regular expression RE?"
+  (let ((okay? (cl-ppcre:scan-to-strings re s)))
+    (if okay? 
+        (values t nil)
+        (values nil (or error-msg (fmt "must match ~a" re))))))
+
 (defun print/finish (&rest args)
   (apply #'format (cons t args))
   (finish-output))
 
+(defun word-plural (n word)
+  (let ((table '(("doesn't" . "don't")
+                 ("newsgroup" . "newsgroups"))))
+    (let ((w (assoc word table :test #'string=)))
+      (when (not w) (error "word not found"))
+      (if (< n 2) (car w) (cdr w)))))
+
 (defun plural (v suffix)
   (if (> v 1) suffix ""))
 
@@ -309,7 +324,6 @@
 (defun remove-inactive-users! ()
   (loop for u in *accounts* do
     (let ((username (account-username u)))
-      (format t "Username: ~a~%" username)
       (cond ((and (not (locked? username))
                   (inactive-from-never-logged-in? username))
              (post-notification 
@@ -694,7 +708,7 @@
 
 (defun group? (g) 
   (in-groups
-   (directory-p g)))
+   (ignore-errors (directory-p g))))
 
 (defun xgroup? (g) 
   (directory-p g))
@@ -828,9 +842,8 @@
                     :data (str:join (crlf-string) lines)))))
 
 (defun menu (ls)
-  (if (null ls)
+  (loop for item in ls 
-      nil
+        collect (display-fn item)))
-      (cons (display-fn (car ls)) (menu (cdr ls)))))
 
 (defun display-fn (cmd-pair)
   (let ((cmd (cdr cmd-pair)))
@@ -901,7 +914,7 @@
          (make-article 
           :headers 
           (str:join (crlf-string) 
-                    (mapcar (lambda (h)
+                    (mapcar #'(lambda (h)
                                 (format nil "~a: ~a" (car h) (cdr h))) 
                             (cons (cons h (funcall fn)) headers)))
           :body (article-body (parse-article bs)))))))
@@ -919,44 +932,46 @@
 (defun ensure-date (bs)
   (ensure-header "date" #'get-date bs))
 
-(defun newsgroups-header->list (s)
-  (mapcar (lambda (n) (str:trim (string-downcase n))) (str:split "," s)))
-
 (defun cmd-post (r)
   (with-auth 
       (send-response! 
-       (make-response :code 340 
+       (make-response 
+        :code 340 
         :data (format nil "Okay, go ahead. Suggested message-id ~a."
                                     (suggest-message-id))))
     (let* ((bs (nntp-read-article)))
       (multiple-value-bind (okay? error) (conforms? bs)
-        (if (not okay?)
+        (cond ((not okay?)
-            (make-response :code 400 :request r
+               (make-response 
-                           :data (format nil "Sorry. Your article doesn't conform: ~a." error))
+                :code 400 :request r
-            (multiple-value-bind (code reply) (post bs)
+                :data (format nil "Sorry. Your article doesn't conform: ~a." error)))
-              (make-response :code code :request r :data reply)))))))
+              (t (multiple-value-bind (code reply) (post bs)
+                   (make-response :code code :request r :data reply))))))))
 
 (defun post (bs)
   (let ((ngs (newsgroups-header->list 
               (get-header "newsgroups" (parse-headers
                                         (article-headers
                                          (parse-article bs))))))
-        ngs-dont-exist)
+        (ngs-dont-exist))
-    (dolist (ng ngs)
+    (dolist (g ngs)
-      (if (and (group-name-conforms? ng)
+      (if (or (not (group-name-conforms? g))
-               (group? ng))
+              (not (group? g)))
+          (push g ngs-dont-exist)))
+    (if (zerop (length ngs-dont-exist))
         (progn
+          (dolist (ng ngs)
             (let ((a (ensure-date (ensure-mid bs))))
               (save-article-insist ng (get-next-article-id ng) a (extract-mid a))
               (update-last-post-date! (client-username *client*))))
-          (push ng ngs-dont-exist)))
+          (values 240 (data "Thank you! Your article has been saved.")))
-    (if (zerop (- (length ngs) (length ngs-dont-exist)))
+        (values 400 (data "Sorry. We did not post your article to any newsgroup because "
-        (values 400 "Sorry. There was not a single valid newsgroup specified.")
+                          "the " (word-plural (length ngs-dont-exist) "newsgroup") " " 
-        (values 240 (data "Thank you! Your article has been saved."
-                          (when ngs-dont-exist
-                            (data " However, the groups "
                           (str:join ", " (sort ngs-dont-exist #'string<))
-                                  " just don't exist.")))))))
+                          " just " (word-plural (length ngs-dont-exist) "doesn't") " exist.")))))
+
+(defun newsgroups-header->list (s)
+  (mapcar #'(lambda (n) (str:trim (string-downcase n))) (str:split "," s)))
 
 (defun update-last-post-date! (username)
   (let ((u (get-account username)))
@@ -1029,7 +1044,7 @@
 
 (defun add-crlf-between (ls-of-ls)
   ;; Add \r\n to each ``line''. Returns List-of Byte.
-  (mapcar (lambda (ls) (append ls (list 13 10))) ls-of-ls))
+  (mapcar #'(lambda (ls) (append ls (list 13 10))) ls-of-ls))
 
 (defun string->bytes (s)
   (map 'list #'char-code s))
@@ -1061,10 +1076,10 @@
                                      :data (format nil "group ~a created" g)))))))))))
 
 (defun group-name-conforms? (g)
-  (let ((okay? (cl-ppcre:scan-to-strings "^([a-z0-9]+)" g)))
+  (conforms-to? g "^[^\\s/]+$"))
-    (if okay? 
+
-        (values t nil)
+(defun user-name-conforms? (u)
-        (values nil "must match ^([a-z0-9]+)"))))
+  (conforms-to? u "^[^\\s]+$"))
 
 (defun cmd-create-account (r)
   (with-auth 
@@ -1104,13 +1119,17 @@
          (a (make-account :username u
                           :pass (string->sha256 (str:upcase p))
                           :creation (get-universal-time))))
-    (if (get-account u)
+    (multiple-value-bind (okay? reason) (user-name-conforms? u)
-        (values nil (fmt "account ~a already exists" u))
+      (declare (ignore reason))
-        (progn
+      (cond ((not okay?)
+             (values nil (fmt "username must conform to ^[^\\s]+$")))
+            ((get-account u)
+             (values nil (fmt "account ~a already exists" u)))
+            (t
               (push u (account-friends (get-account invited-by)))
               (push a *accounts*)
               (write-accounts!)
-          (values (str:upcase username) p)))))
+              (values (str:upcase username) p))))))
 
 (defun write-accounts! ()
   (let ((name
@@ -1205,7 +1224,8 @@
   (let ((u (get-account username)))
     (and 
      u
-     (cond ((integerp (account-pass u))
+     (cond ((null (account-pass u)) nil)
+           ((integerp (account-pass u))
             (eq (sxhash pass) (account-pass u)))
            ((arrayp (account-pass u))
             (equalp (string->sha256 pass) (account-pass u)))
@@ -1232,7 +1252,7 @@
 
 (defun list-users ()
   (read-accounts!)
-  (mapcar (lambda (row) (cadr row))
+  (mapcar #'(lambda (row) (cadr row))
           (sort
            (loop for u in *accounts* 
                  collect (list (account-username u) 
@@ -1247,7 +1267,7 @@
                                         (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)))))
+           #'string<= :key #'(lambda (row) (car row)))))
 
 (defun universal-to-human (s)
   (format-timestring
@@ -1264,8 +1284,13 @@
   (make-response :code 200 :data (format nil "state: ~a" *client*) :request r))
 
 (defun cmd-repl (r)
+  (if *enable-nntp-repl*
       (with-auth
-      (repl r)))
+          (repl r))
+      (make-response 
+       :code 400
+       :data "The REPL has been *explicitly* disabled by the sysadmin. :("
+       :request r)))
 
 (defun notify-group-created (g)
   (post-notification 
@@ -1294,7 +1319,7 @@
    :headers (data 
              (add-crlf-between 
               (mapcar 
-               (lambda (p) (data (format nil "~a: ~a" (car p) (cdr p))))
+               #'(lambda (p) (data (format nil "~a: ~a" (car p) (cdr p))))
                `(("from" . "Loop")
                  ("subject" . ,subject)
                  ("newsgroups" .  "local.control.news")))))
@@ -1304,12 +1329,12 @@
   (list 
    (clingon:make-option
     :string
-    :description "<username> <invited-by> creates a new account"
+    :description "creates a new account"
     :long-name "create-account"
     :key :create-account)
    (clingon:make-option
     :string
-    :description "<username> <new-password> changes password"
+    :description "changes password"
     :long-name "change-passwd"
     :key :change-passwd)
    (clingon:make-option
@@ -1320,10 +1345,15 @@
     :key :list-accounts)
    (clingon:make-option
     :flag
-    :description "runs a REPL"
+    :description "runs a REPL right now"
     :short-name #\r
     :long-name "repl"
     :key :repl)
+   (clingon:make-option
+    :flag
+    :description "disables the NNTP REPL"
+    :long-name "disable-nntp-repl"
+    :key :disable-nntp-repl)
    (clingon:make-option
     :flag
     :description "logging (on stderr)"
@@ -1355,8 +1385,7 @@
          (new-passwd (or given-passwd random-passwd)))
     (if (not (get-account username))
         (println "No such account ``~a''." username)
-        (multiple-value-bind (okay? problem) (change-passwd! username new-passwd)
+        (multiple-value-bind (okay? problem) (change-passwd! username new-passwd)          (if okay?
-          (if okay?
               (println "Okay, account ~a now has password ``~a''." username new-passwd)
               (println "Sorry, could not change password: ~a." problem))))))
 
@@ -1375,12 +1404,16 @@
   (connect-index! "message-id.db")
   (create-index!)
   (let ((args (clingon:command-arguments cmd))
+        (run-server t)
         (repl (clingon:getopt cmd :repl))
         (ca (clingon:getopt cmd :create-account))
         (pa (clingon:getopt cmd :change-passwd))
         (la (clingon:getopt cmd :list-accounts))
-        (logging (clingon:getopt cmd :logging)))
+        (logging (clingon:getopt cmd :logging))
+        (disable-nntp-repl (clingon:getopt cmd :disable-nntp-repl)))
     (setf *debug* logging)
+    (when (or ca pa la)
+        (setf run-server nil))
     (when la
       (cli/list-accounts))
     (when ca
@@ -1389,14 +1422,16 @@
       (cli/change-passwd pa args))
     (when repl
       (repl (make-request :verb "repl" :args '(command-line))))
-    (when (and (not la) (not ca) (not pa) (not repl))
+    (when disable-nntp-repl
+      (setq *enable-nntp-repl* nil))
+    (when run-server
       (server-start))))
 
 (defun cli/command ()
   (clingon:make-command
    :name "loop"
    :description "An NNTP server for a circle of friends."
-   :version "9575ac2"
+   :version "a89e088"
    :license "GPL v3"
    :options (cli/options)
    :handler #'cli/main-with-handlers))
@@ -1426,23 +1461,42 @@
   (send-response! 
    (make-response 
     :code 200 
-    :data "Welcome! I am LOOP 9575ac2. Say ``help'' for a menu.")))
+    :data "Welcome! I am LOOP a89e088. Say ``help'' for a menu.")))
-
 (setq lisp-unit:*print-failures* t)
-(define-test first-test-of-the-west
-  (assert-equal 0 0))
-
-(define-test requests
-  (let ((nil-request-1 (make-request))
-        (nil-request-2 (make-request :said "  ")))
-    (assert-true (request=? nil-request-1 (parse-request nil-request-1)))
-    (assert-true (request=? nil-request-2 (parse-request nil-request-2)))
-    (assert-true (request=? nil-request-1 nil-request-2))))
-
-(define-test commands
-  (let ((ht (make-hash-table))
-        (c1 (make-command :fn #'cons :verb 'c1 :description "cons cmd"))
-        (c2 (make-command :fn #'list :verb 'c2 :description "list cmd")))))
-
 (define-test dispatching
-  (assert-true (equalp (empty-response) (dispatch (empty-request)))))
+  (assert-true (equalp (empty-response) (dispatch (make-request)))))
+
+(defun unix->nntp (s) 
+  "I substitute \n for \r\n"
+  (str:replace-all (fmt "~a" #\linefeed) (crlf-string) s))
+
+(defvar a-post (unix->nntp "From: root
+Message-id: <pwtdldytefplntosymvo@loop>
+Subject: test
+Newsgroups: local.test
+
+Quickest test of the West.
+"))
+
+(defvar a-bad-post (unix->nntp "From: root
+Message-id: <pwtdldytefplntosymvp@loop>
+Subject: a bad test
+Newsgroups: local.test, bad.newsgroup
+
+A bad test from the biggest mouth of the south.
+"))
+
+(define-test post-wrong-newsgroup
+  (multiple-value-bind (code msg) (post (string->bytes a-bad-post))
+    (declare (ignore msg))
+    (assert-true (equal code 400))))
+
+(define-test post-okay
+  (read-accounts!)
+  (connect-index! "test.db")
+  (create-index!)
+  (setq *client* (make-client :username "ROOT" :auth? 'yes))
+  (multiple-value-bind (code msg) (post (string->bytes a-post))
+    (declare (ignore msg))
+    (assert-true (equal code 240)))
+  (clsql:disconnect))

loop.nw

@@ -47,6 +47,7 @@
   {a circle out of fashion}}
 \date{January 2024}
 \begin{document}
+\pdfbookmark[1]{Introduction}{intro}
 \fontfamily{cmr}\selectfont
 \maketitle
 %\setlength{\parskip}{3pt}
@@ -54,9 +55,9 @@
 
 \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.  That's how backwards they are.
+be made in writing and not in a hurry.  To give you an idea, they
-To give you an idea, they write \Lp\ in Lisp---jurassic technology.
+write \Lp\ in jurassic technology.  You wouldn't pay them any
-We surely wouldn't pay them any attention.
+attention.
 %
 \begin{verbatim}
          Drunk and dressed in their best brown baggies and their platform soles
@@ -74,6 +75,24 @@ 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.
 
+\begin{figure}[!htb]
+  \centering \includegraphics[width=0.8\linewidth]{images/gnus-summary.png}
+  \caption{Gnus, a news reader embedded in the GNU EMACS text editor.}
+  \label{fg:gnus}
+\end{figure}
+
+\begin{figure}[!htb]
+  \centering \includegraphics[width=0.8\linewidth]{images/tbird-summary.png}
+  \caption{Thunderbird, a news reader produced by the Mozilla Foundation.}
+  \label{fg:bird}
+\end{figure}
+
+\begin{figure}[!htb]
+  \centering \includegraphics[width=0.8\linewidth]{images/sylpheed-summary.png}
+  \caption{Sylpheed, a news reader produced by Hiroyuki Yamamoto.}
+  \label{fg:sylpheed}
+\end{figure}
+
 There are surely inconveniences in using e-mail as conference medium.
 For example, after John has been added to the loop, he is not able to
 leave by his own account.  He needs to ask everyone involved to stop
@@ -110,7 +129,7 @@ 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 news groups are called ``articles''.
+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
@@ -118,41 +137,22 @@ NNTP-aware programs.  You could write your own.  Figures
 \ref{fg:gnus}--\ref{fg:sylpheed} show a few programs for reading
 network news via NNTP.
 
-\begin{figure}[!htb]
+\section*{Principles for a discussion group}\label{principles}
-  \centering \includegraphics[width=0.8\linewidth]{images/gnus-summary.png}
+\pdfbookmark[1]{Principles for a discussion group}{principles} We
-  \caption{Gnus, a news reader embedded in the GNU EMACS text editor.}
+believe a discussion group should be small and grow slowly.  By
-  \label{fg:gnus}
+``slowly'', we mean that each member comes in through an invitation.
-\end{figure}
+This way, the group being closed by definition, we keep spam out and
-
+give members a certain sense of privilege.  A discussion group should
-\begin{figure}[!htb]
+be formed by interested people.  If a participant doesn't log-in for a
-  \centering \includegraphics[width=0.8\linewidth]{images/tbird-summary.png}
+certain period of time, \lp\ locks the participant's account---see
-  \caption{Thunderbird, a news reader produced by the Mozilla Foundation.}
+Section \ref{sec:inactive-users}.  The account can be reactivated, but
-  \label{fg:bird}
+it will take asking another participant (with an active account) to do
-\end{figure}
+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
-\begin{figure}[!htb]
+cohesion in the discussion groups.  When an account is locked or
-  \centering \includegraphics[width=0.8\linewidth]{images/sylpheed-summary.png}
+unlocked, an article is posted to the group {\tt local.control.news},
-  \caption{Sylpheed, a news reader produced by Hiroyuki Yamamoto.}
+so everyone knows who is leaving and arriving.  This way, participants
-  \label{fg:sylpheed}
+get to have an idea of who is reading them.
-\end{figure}
-
-\noindent{\bf Principles for a discussion group}. We believe a discussion group
-should be small and grow slowly.  By ``slowly'', we mean that each
-member comes in through an invitation.  This way, the group being
-closed by definition, we keep spam out and give members a certain
-sense of privilege.
-
-A discussion group should be formed by interested people.  If a
-participant doesn't log-in for a certain period of time, \lp locks the
-participant's account---see Section \ref{sec:inactive-users}.  The
-account can be reactivated, but it will take asking another
-participant (with an active account) to do so.  In other words,
-there's an encouragement for an uninterested member not to come back
-to the \lp.  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.
 
 Each invitation comes with a certain responsibility: it's possible to
 see who invited who.  If {\tt BOB} misbehaves, everyone gets to see
@@ -181,9 +181,11 @@ Hereafter, our conversation continues in Lisp.  Understanding how
 \lp\ is made is only necessary if you intend to modify it.  If you
 just want to use the system, you probably should stop right here.
 
-\section{How to install}
+\section*{How to install} 
 
-See \href{https://git.antartida.xyz/loop/srv/raw/branch/main/README}{[[README]]}.
+See
+\href{https://git.antartida.xyz/loop/srv/raw/branch/main/README}{[[README]]}
+in \lp's source code.
 
 \section{Implementation strategy}\label{sec:design}
 
@@ -658,7 +660,7 @@ An NNTP server for a circle of friends.
 @ 
 
 <<Version>>=
-9575ac2
+a89e088
 @ 
 
 \section{Parsing of requests}
@@ -685,19 +687,20 @@ 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.
+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.
 
 <<Command-line parsing>>=
 (defun cli/options () 
   (list 
    (clingon:make-option
     :string
-    :description "<username> <invited-by> creates a new account"
+    :description "creates a new account"
     :long-name "create-account"
     :key :create-account)
    (clingon:make-option
     :string
-    :description "<username> <new-password> changes password"
+    :description "changes password"
     :long-name "change-passwd"
     :key :change-passwd)
    (clingon:make-option
@@ -708,10 +711,15 @@ to support a two-argument option, so I hacked a solution away.
     :key :list-accounts)
    (clingon:make-option
     :flag
-    :description "runs a REPL"
+    :description "runs a REPL right now"
     :short-name #\r
     :long-name "repl"
     :key :repl)
+   (clingon:make-option
+    :flag
+    :description "disables the NNTP REPL"
+    :long-name "disable-nntp-repl"
+    :key :disable-nntp-repl)
    (clingon:make-option
     :flag
     :description "logging (on stderr)"
@@ -719,12 +727,9 @@ to support a two-argument option, so I hacked a solution away.
     :key :logging)))
 @ 
 
-The command-line options form a language.  The user specifies
+We implement first the procedures that handle options that represent
-everything he wants with flags.  If he wants nothing, for instance, he
+an entire program.  For example, saying [[--list-accounts]] is like
-specifies nothing and then nothing happens.  XXX: I'd like to have a
+running a program [[./list-accounts]].
-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 ()
@@ -752,13 +757,15 @@ to do that yet.
          (new-passwd (or given-passwd random-passwd)))
     (if (not (get-account username))
         (println "No such account ``~a''." username)
-        (multiple-value-bind (okay? problem) (change-passwd! username new-passwd)
+        (multiple-value-bind (okay? problem) (change-passwd! username new-passwd)          (if okay?
-          (if okay?
               (println "Okay, account ~a now has password ``~a''." username new-passwd)
               (println "Sorry, could not change password: ~a." problem))))))
 @ %def cli/change-passwd cli/list-accounts cli/create-account
 
-Now let's write the main procedure in command-line parsing.
+Now let's write the main procedure in command-line parsing.  Notice
+that because of the design of the [[clingon]] library, command-line
+parsing becomes the main procedure of \lp.  In other words, \lp's
+service starts with [[server-start]].
 
 <<Command-line parsing>>=
 (defun cli/main-with-handlers (cmd)
@@ -776,12 +783,16 @@ Now let's write the main procedure in command-line parsing.
   (connect-index! "message-id.db")
   (create-index!)
   (let ((args (clingon:command-arguments cmd))
+        (run-server t)
         (repl (clingon:getopt cmd :repl))
         (ca (clingon:getopt cmd :create-account))
         (pa (clingon:getopt cmd :change-passwd))
         (la (clingon:getopt cmd :list-accounts))
-        (logging (clingon:getopt cmd :logging)))
+        (logging (clingon:getopt cmd :logging))
+        (disable-nntp-repl (clingon:getopt cmd :disable-nntp-repl)))
     (setf *debug* logging)
+    (when (or ca pa la)
+        (setf run-server nil))
     (when la
       (cli/list-accounts))
     (when ca
@@ -790,7 +801,9 @@ Now let's write the main procedure in command-line parsing.
       (cli/change-passwd pa args))
     (when repl
       (repl (make-request :verb "repl" :args '(command-line))))
-    (when (and (not la) (not ca) (not pa) (not repl))
+    (when disable-nntp-repl
+      (setq *enable-nntp-repl* nil))
+    (when run-server
       (server-start))))
 
 (defun cli/command ()
@@ -967,8 +980,7 @@ 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.} XXX: replace menu with
+reason to think we're doing to debug it.}
-[[loop]].
 
 <<Command help>>=
 (defun cmd-help (r)
@@ -978,10 +990,10 @@ reason to think we're doing to debug it.} XXX: replace menu with
      (make-response :code 200 :multi-line 'yes
                     :request r 
                     :data (str:join (crlf-string) lines)))))
+
 (defun menu (ls)
-  (if (null ls)
+  (loop for item in ls 
-      nil
+        collect (display-fn item)))
-      (cons (display-fn (car ls)) (menu (cdr ls)))))
 
 (defun display-fn (cmd-pair)
   (let ((cmd (cdr cmd-pair)))
@@ -1043,10 +1055,26 @@ Syntax error. Say ``authinfo USER /your-name/'' then ``authinfo PASS /your-pass/
 
 \subsection{{\tt CREATE-ACCOUNT}}
 
-We allow authenticated members to invite their friends.  Notice that
+We allow authenticated members to invite their friends, which creates
-we're not doing any kind of checking on the username.  XXX: take a
+a tree of people.  ({\em An idea}.  We could envision that each tree
-look at how we verify group names match a certain regex and apply the
+trunk manages the rest of the tree underneath it.  So I invite you, I
-same check here.
+could change your password, say, or handle any problems you might
+have.  This decentralizes system administration, easing the support
+burden.)
+
+The name of each user must conform to the expression
+
+<<Form of user names>>=
+^[^\\s]+$
+@
+
+Same as in @<<Form of newsgroup names@>>.  We'll let users create
+whatever complicated user names they want.  If they can type it up,
+it's their problem.
+
+<<Command create-account>>=
+(defun user-name-conforms? (u)
+  (conforms-to? u "<<Form of user names>>"))
 
 <<Command create-account>>=
 (defun cmd-create-account (r)
@@ -1094,13 +1122,17 @@ same check here.
          (a (make-account :username u
                           :pass (string->sha256 (str:upcase p))
                           :creation (get-universal-time))))
-    (if (get-account u)
+    (multiple-value-bind (okay? reason) (user-name-conforms? u)
-        (values nil (fmt "account ~a already exists" u))
+      (declare (ignore reason))
-        (progn
+      (cond ((not okay?)
+             (values nil (fmt "username must conform to <<Form of user names>>")))
+            ((get-account u)
+             (values nil (fmt "account ~a already exists" u)))
+            (t
               (push u (account-friends (get-account invited-by)))
               (push a *accounts*)
               (write-accounts!)
-          (values (str:upcase username) p)))))
+              (values (str:upcase username) p))))))
 @ %def CREATE-ACCOUNT new-account!
 
 Notice that we have a race condition in [[write-accounts]].  What is
@@ -1230,7 +1262,8 @@ there is a macro emerging here called [[with-upcase-args]]. %% TODO
   (let ((u (get-account username)))
     (and 
      u
-     (cond ((integerp (account-pass u))
+     (cond ((null (account-pass u)) nil)
+           ((integerp (account-pass u))
             (eq (sxhash pass) (account-pass u)))
            ((arrayp (account-pass u))
             (equalp (string->sha256 pass) (account-pass u)))
@@ -1264,11 +1297,12 @@ invited who.
         maximizing (length (account-username u))))
 
 (defun list-users ()
-  (read-accounts!)
+  (mapcar
-  (mapcar (lambda (row) (cadr row))
+   #'(lambda (row) (cadr row))
    (sort
     (loop for u in *accounts* 
-                 collect (list (account-username u) 
+          collect (list
+                   (account-username u) 
                    (fmt "~v@a~a, ~a, invited ~a" 
                         (size-of-longest-username)
                         (account-username u)
@@ -1280,7 +1314,7 @@ invited who.
                             (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)))))
+    #'string<= :key #'(lambda (row) (car row)))))
 
 (defun universal-to-human (s)
   (format-timestring
@@ -1464,7 +1498,7 @@ We just need to verify if the group exists and modify [[*client*]].
 
 (defun group? (g) 
   (in-groups
-   (directory-p g)))
+   (ignore-errors (directory-p g))))
 
 (defun xgroup? (g) 
   (directory-p g))
@@ -1535,7 +1569,15 @@ 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.
+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.
 
 <<Commands head, body, article>>=
 (defun typical-cmd-response (code r g i get-data)
@@ -1709,7 +1751,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. %% TODO
+parsing.  Am I doing something wrong?  I wonder.
 
 <<Command post>>=
 (defun unparse-article (parsed)
@@ -1737,7 +1779,7 @@ now, however, we have only these two to worry about.
          (make-article 
           :headers 
           (str:join (crlf-string) 
-                    (mapcar (lambda (h)
+                    (mapcar #'(lambda (h)
                                 (format nil "~a: ~a" (car h) (cdr h))) 
                             (cons (cons h (funcall fn)) headers)))
           :body (article-body (parse-article bs)))))))
@@ -1755,69 +1797,99 @@ now, however, we have only these two to worry about.
   (ensure-header "date" #'get-date bs))
 @ %def ensure-mid ensure-date
 
-Now it's time to look at the header \verb|newsgroups|.  (XXX: Our code
+Now it's time to look at the header \verb|newsgroups|.  XXX: we need
-here is a bit confusing, but I don't know the best to do here, so I'm
+to rewrite this because we have that plan of verifying everything
-going ahead unpretentiously.)  If we get approved by [[conforms?]],
+there is to verify up front in [[conforms?]].  So when we invoke
-then we verify the list of newsgroups right away.
+[[post]], there's nothing else to verify.  We're verifying in two
+places at the same time.
 
 The name of each group must conform to the expression
 
 <<Form of newsgroup names>>=
-^([a-z0-9]+)
+^[^\\s/]+$
-@ %def the-form-of-newsgroup-names
+@
 
-I think people should have total freedom in naming groups.  If users
+In other words, let group names go wild.  They cannot contain a slash
-create groups that mess up the local organization, then people should
+or a space of any kind anywhere on the name---more literally: they
-discuss the matter and find a solution.  Let's let people mess it up
+must begin with any character that's not a space and must have at
-instead of trying to stop them---the way of the hacker.
+least one character. The problem wish slashes is that each group will
+be a directory on a UNIX file system, so we cannot let slashes appear.
+
+People should have total freedom in naming groups.  If users create
+groups that mess up the local organization, then people should discuss
+the matter and find a solution.  Let's let people mess it up instead
+of trying to stop them.
 
 <<Command post>>=
-(defun newsgroups-header->list (s)
-  (mapcar (lambda (n) (str:trim (string-downcase n))) (str:split "," s)))
-
 (defun cmd-post (r)
   (with-auth 
       (send-response! 
-       (make-response :code 340 
+       (make-response 
+        :code 340 
         :data (format nil "Okay, go ahead. Suggested message-id ~a."
                                     (suggest-message-id))))
     (let* ((bs (nntp-read-article)))
       (multiple-value-bind (okay? error) (conforms? bs)
-        (if (not okay?)
+        (cond ((not okay?)
-            (make-response :code 400 :request r
+               (make-response 
-                           :data (format nil "Sorry. Your article doesn't conform: ~a." error))
+                :code 400 :request r
-            (multiple-value-bind (code reply) (post bs)
+                :data (format nil "Sorry. Your article doesn't conform: ~a." error)))
-              (make-response :code code :request r :data reply)))))))
+              (t (multiple-value-bind (code reply) (post bs)
+                   (make-response :code code :request r :data reply))))))))
+@ 
 
+It's time to write the action of posting.  One thing to keep in mind
+is cross-posting.  First, notice that we're---so far---duplicating
+articles on the file system.  (We will undo that once we reimplement
+our index.  More to follow.)  More importantly, we cannot let the user
+post to any group if one of the groups is incorrectly named---for
+example, when the group doesn't exist.  Why don't we post to the ones
+that are correct and warn the user of the ones that are incorrect?
+Because that is not prudent.  The user could be trying to publish news
+to be received at the same time by various groups.  We would make such
+plans all go down the drain.
+
+We collect a list of newsgroups that don't exist (or whose names do
+not conform for any reason).  If we find any such group, then we
+refuse posting and return a 400 code with a message describing which
+group names failed.  Otherwise we save the article.
+
+<<Command post>>=
 (defun post (bs)
   (let ((ngs (newsgroups-header->list 
               (get-header "newsgroups" (parse-headers
                                         (article-headers
                                          (parse-article bs))))))
-        ngs-dont-exist)
+        (ngs-dont-exist))
-    (dolist (ng ngs)
+    (dolist (g ngs)
-      (if (and (group-name-conforms? ng)
+      (if (or (not (group-name-conforms? g))
-               (group? ng))
+              (not (group? g)))
+          (push g ngs-dont-exist)))
+    (if (zerop (length ngs-dont-exist))
         (progn
+          (dolist (ng ngs)
             (let ((a (ensure-date (ensure-mid bs))))
               (save-article-insist ng (get-next-article-id ng) a (extract-mid a))
               (update-last-post-date! (client-username *client*))))
-          (push ng ngs-dont-exist)))
+          (values 240 (data "Thank you! Your article has been saved.")))
-    (if (zerop (- (length ngs) (length ngs-dont-exist)))
+        (values 400 (data "Sorry. We did not post your article to any newsgroup because "
-        (values 400 "Sorry. There was not a single valid newsgroup specified.")
+                          "the " (word-plural (length ngs-dont-exist) "newsgroup") " " 
-        (values 240 (data "Thank you! Your article has been saved."
-                          (when ngs-dont-exist
-                            (data " However, the groups "
                           (str:join ", " (sort ngs-dont-exist #'string<))
-                                  " just don't exist.")))))))
+                          " just " (word-plural (length ngs-dont-exist) "doesn't") " exist.")))))
+
+(defun newsgroups-header->list (s)
+  (mapcar #'(lambda (n) (str:trim (string-downcase n))) (str:split "," s)))
 @ %def post
 
-XXX: Oh, have a look at that.  We accept the article even if there are
+XXX: notice we parse the article again to extract information from it
-invalid groups.  We should not do that.  A user might only want to
+that we need during [[post]].  That's not only a waste of
-post at all if his message is cross-posted to a few groups.  A user
+time---because we already did that---, but it makes [[post]] a lot
-might easily mistype a group name.  The Right Thing here is more
+less generic.  Perhaps [[conforms?]] should return a data structure
-likely to stop posting completely with an error message telling the
+that contains all that [[post]] needs.  Then [[post]] consumes that
-user to either remove the invalid group of type it up properly.
+and saves the article more easily.  That's a better idea.  I think
+[[post]] should not even use variables such as [[*client*]].  The
+username to which to update the last-seen date should be included in
+the data structure.
 
 <<Command post>>=
 (defun update-last-post-date! (username)
@@ -1935,7 +2007,7 @@ never comes from the NNTP protocol because there's is always a {\tt
 
 (defun add-crlf-between (ls-of-ls)
   ;; Add \r\n to each ``line''. Returns List-of Byte.
-  (mapcar (lambda (ls) (append ls (list 13 10))) ls-of-ls))
+  (mapcar #'(lambda (ls) (append ls (list 13 10))) ls-of-ls))
 
 (defun string->bytes (s)
   (map 'list #'char-code s))
@@ -2043,23 +2115,34 @@ all or it has been discussed with the community beforehand.
                                      :data (format nil "group ~a created" g)))))))))))
 
 (defun group-name-conforms? (g)
-  (let ((okay? (cl-ppcre:scan-to-strings "<<Form of newsgroup names>>" g)))
+  (conforms-to? g "<<Form of newsgroup names>>"))
-    (if okay? 
-        (values t nil)
-        (values nil "must match <<Form of newsgroup names>>"))))
 @ %def CREATE-GROUP group-name-conforms?
 
 \subsection{{\tt REPL}}
 
 \lp\ is totally {\em hackable}.  Users can say {\tt repl} to have
-complete control over their \lxxp\ process.  XXX: we should implement
+complete control over their \lxxp\ process.
-an option [[--disable-repl]] so that REPL hacking is turned off.
-(This would mean your users are not true hackers.)
 
 <<Command repl>>=
 (defun cmd-repl (r)
+  (if *enable-nntp-repl*
       (with-auth
-      (repl r)))
+          (repl r))
+      (make-response 
+       :code 400
+       :data "The REPL has been *explicitly* disabled by the sysadmin. :("
+       :request r)))
+@
+
+If your users are not the hacker-type, you can disable the NNTP REPL
+with the command-line option [[--disable-nntp-repl]].  We decide not
+to hide the command in the list of commands given by saying {\tt HELP}
+to \lp\ because this way users are advertised about the commands that
+exist---they could be having fun, but their sysadmin doesn't think
+they're skilled enough.
+
+<<Global variable that decides whether to enable the NNTP REPL>>=
+(defparameter *enable-nntp-repl* t)
 @ 
 
 \section{Publication of news}
@@ -2096,7 +2179,7 @@ invitations {\em et cetera} are published there.
    :headers (data 
              (add-crlf-between 
               (mapcar 
-               (lambda (p) (data (format nil "~a: ~a" (car p) (cdr p))))
+               #'(lambda (p) (data (format nil "~a: ~a" (car p) (cdr p))))
                `(("from" . "Loop")
                  ("subject" . ,subject)
                  ("newsgroups" .  "local.control.news")))))
@@ -2171,7 +2254,7 @@ working.  Since we work with only one, we pretty much never need to
 specify anything.
 
 <<Reference to the database>>=
-(defvar *default-database* nil)
+(defparameter *default-database* nil)
 @ %def *default-database*
 
 <<How to create and connect to the index>>=
@@ -2343,16 +2426,15 @@ Index built.
 
 \section{Deletion and locking of inactive accounts}\label{sec:inactive-users}
 
-XXX: remove this paragraph from here; present the program first and
+We now implement some of the \hyperref[principles]{principles} exposed
-then talk about it.  In [[remove-friend]], note that [[username]] is
+earlier on page~\pageref{principles}.  The program
-the account name and [[friend]] is the name of the account being
+@<<cron-remove-inactive-users.lisp@>> would be run by {\tt cron} every
-removed.  Notice as well that we only know who invited the person
+day (at midnight, say).  It checks all accounts that are inactive and
-after we can get a hold of the account in [[accounts.lisp]].  This
+either locks them (to be deleted later) or deletes them {\em for
-means we must scan each account to delete an account---we can't delete
+  good}.  If you want to keep accounts forever, just don't run the
-an account and still leave the account as someone's friend.
+program.  XXX: our idea is to also delete {\em for good} all accounts
-
+that are locked (by the same period of time), but we have not yet done
-The program [[cron-remove-inactive-users.lisp]] can be executed every
+that.
-day at midnight, say.
 
 <<cron-remove-inactive-users.lisp>>=
 <<Quicklisp loading preamble>>
@@ -2364,15 +2446,12 @@ day at midnight, say.
 (write-accounts!)
 @ %def cron-remove-inactive-users.lisp
 
-In [[remove-account]], we probably should use [[delete-if]] as well on
+The entire program is really [[remove-inactive-users!]].
-the list of friends since it is effectively what we are doing there
-with [[setf]]. %% TODO
 
 <<How to remove inactive users>>=
 (defun remove-inactive-users! ()
   (loop for u in *accounts* do
     (let ((username (account-username u)))
-      (format t "Username: ~a~%" username)
       (cond ((and (not (locked? username))
                   (inactive-from-never-logged-in? username))
              (post-notification 
@@ -2398,10 +2477,10 @@ with [[setf]]. %% TODO
 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
+{\em sequence}''.  More important is to understand that we really must
-must {\tt setf} the return, otherwise we might find the deletion did
+{\tt setf} the return, otherwise we might find the deletion did not
-not take effect---for example, when deleting the first element of a
+take effect---for example, when deleting the first element of a list.
-list.  (This deserves a better explanation, but if you know how linked
+(XXX: 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.)
 
@@ -2425,7 +2504,9 @@ Accounts that do not have a creation date up until today---Tue Sep 17
 21:37:18 ESAST 2024---will have its creation dates migrated to the
 \Lp\ epoch, which is January 1st 2024, the exact month in which
 \Lp\ was written.  But notice that this migration is done only once.
-New system administrators of \Lp\ will never need to run this.
+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>>=
 (defun loop-epoch ()
@@ -2522,13 +2603,22 @@ example, when we need to access the group database, we use
   `(let ((*default-pathname-defaults* (truename ,dir)))
      (uiop:with-current-directory (,dir)
        ,@body)))
+@ 
 
+Notice that we set [[*default-pathname-defaults*]] and we set the
+process' current working directory.  That's not necessary because Lisp
+always uses [[*default-pathname-defaults*]] and does not care about
+the current working directory.  We did this out of the fact that we
+used to invoke [[renameat2]] through the [[cffi]], but we don't use it
+any more.
+
+<<Macros>>=
 (defmacro in-groups (&rest body) `(in-dir "groups/" ,@body))
 
 (defun in-group-lambda (g fn) (in-dir g (funcall fn)))
 
 (defmacro in-group (g &rest body)
-  `(in-group-lambda ,(fmt "groups/~a/" g) (lambda () ,@body)))
+  `(in-group-lambda ,(fmt "groups/~a/" g) #'(lambda () ,@body)))
 
 (defmacro with-group (g r &rest body)
   (let ((g-var (gensym))
@@ -2575,10 +2665,24 @@ 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>>=
+(defun conforms-to? (s re &optional error-msg)
+  "Does string S conform to regular expression RE?"
+  (let ((okay? (cl-ppcre:scan-to-strings re s)))
+    (if okay? 
+        (values t nil)
+        (values nil (or error-msg (fmt "must match ~a" re))))))
+
 (defun print/finish (&rest args)
   (apply #'format (cons t args))
   (finish-output))
 
+(defun word-plural (n word)
+  (let ((table '(("doesn't" . "don't")
+                 ("newsgroup" . "newsgroups"))))
+    (let ((w (assoc word table :test #'string=)))
+      (when (not w) (error "word not found"))
+      (if (< n 2) (car w) (cdr w)))))
+
 (defun plural (v suffix)
   (if (> v 1) suffix ""))
 
@@ -2644,30 +2748,76 @@ means 2 bytes.  So our conversion is just removing the first byte.
 
 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 past decisions in
+for us to trust we can move forward without breaking important past
-the code.
+decisions in the code.  XXX: 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.
+
+When testing, it's important for us not to clutter a production
+system---we will want to run tests on production systems.  So what we
+need to do is to wrap any file system modification to a certain other
+directory in which \lp's tests will find the groups directory in
+place.  Making that happen is as simple as changing
+[[*default-pathname-defaults*]].
 
 <<Test procedures>>=
 (setq lisp-unit:*print-failures* t)
-(define-test first-test-of-the-west
-  (assert-equal 0 0))
-
-(define-test requests
-  (let ((nil-request-1 (make-request))
-        (nil-request-2 (make-request :said "  ")))
-    (assert-true (request=? nil-request-1 (parse-request nil-request-1)))
-    (assert-true (request=? nil-request-2 (parse-request nil-request-2)))
-    (assert-true (request=? nil-request-1 nil-request-2))))
-
-(define-test commands
-  (let ((ht (make-hash-table))
-        (c1 (make-command :fn #'cons :verb 'c1 :description "cons cmd"))
-        (c2 (make-command :fn #'list :verb 'c2 :description "list cmd")))))
-
 (define-test dispatching
-  (assert-true (equalp (empty-response) (dispatch (empty-request)))))
+  (assert-true (equalp (empty-response) (dispatch (make-request)))))
+
+(defun unix->nntp (s) 
+  "I substitute \n for \r\n"
+  (str:replace-all (fmt "~a" #\linefeed) (crlf-string) s))
+
+(defvar a-post (unix->nntp "From: root
+Message-id: <pwtdldytefplntosymvo@loop>
+Subject: test
+Newsgroups: local.test
+
+Quickest test of the West.
+"))
+
+(defvar a-bad-post (unix->nntp "From: root
+Message-id: <pwtdldytefplntosymvp@loop>
+Subject: a bad test
+Newsgroups: local.test, bad.newsgroup
+
+A bad test from the biggest mouth of the south.
+"))
+
+(define-test post-wrong-newsgroup
+  (multiple-value-bind (code msg) (post (string->bytes a-bad-post))
+    (declare (ignore msg))
+    (assert-true (equal code 400))))
+
+(define-test post-okay
+  (read-accounts!)
+  (connect-index! "test.db")
+  (create-index!)
+  (setq *client* (make-client :username "ROOT" :auth? 'yes))
+  (multiple-value-bind (code msg) (post (string->bytes a-post))
+    (declare (ignore msg))
+    (assert-true (equal code 240)))
+  (clsql:disconnect))
 @ %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.
+
 \section{How to produce the binary executable}
 
 Just say {\tt make loop} to your shell.
@@ -2752,7 +2902,7 @@ something to think about.
 
 (defpackage #:loop
   (:use :common-lisp :local-time)
-  (:import-from :lisp-unit define-test)
+  (:import-from :lisp-unit define-test assert-true)
   (:import-from :org.shirakumo.filesystem-utils 
                 directory-p list-directories list-files)
   (:import-from :sb-sys interactive-interrupt)
@@ -2792,17 +2942,14 @@ something to think about.
 <<Command users>>
 <<Command dd>>
 <<Command repl>>
-
 <<Broadcasting>>
-
 <<Command-line parsing>>
-
 <<Main loop>>
-
 <<Test procedures>>
 @ %def
 
 <<Global variables>>=
+(defparameter *debug* nil)
 <<Representation of accounts>>
 <<Representation of a client>>
 <<Representation of requests and responses>>
@@ -2810,7 +2957,7 @@ something to think about.
 <<Representation of commands>>
 <<Representation of articles>>
 <<Definition of maximum allowed inactive periods>>
-(defvar *debug* nil)
+<<Global variable that decides whether to enable the NNTP REPL>>
 @ 
 
 On which packages do we depend?
@@ -2829,7 +2976,87 @@ The \lp\ system definition:
   :description "<<Description>>"
   :depends-on (<<List of packages to be loaded>>)
   :components ((:file "loop")))
-@ %def :loop loop.asd
+@
+
+\section{Other source code}
+
+The shell script {\tt format-def} is invoked whenever we build any
+lisp source code.  That's to format the source code a bit better for
+readers that will be reading it directly.  It is not what we do.  We
+read the documentation in PDF format and we work on the NOWEB file
+{\tt loop.nw}.  But we know that potential readers will not do the
+same and will hack {\tt loop.lisp} directly.  Paying respect to these
+readers, we try to format Lisp source code as best as possible.  So we
+do two things: first, we produce the final source code in an order
+that should produce no warnings during compilation; second, we make
+sure there's one and only one blank line between procedure or macro
+definition.  We don't add a blank line between global variables.
+
+The following shell script does the job.  The first {\tt sed} program
+finds our definitions of interest and inserts a new blank line before
+the definition.  Such action makes function definitions separated by
+two blank lines in some cases.  We then remove the excess with the
+second program.  Notice we need the {\tt -E} option because we're
+using the {\tt |} metacharacter.
+
+The second program find a blank line as its first step.  Then we say
+{\tt N} to expand the pattern space to include the next line.  Then we
+delete the {\em first} blank line and not the second---that's what the
+{\tt D} command does.  This strategy is explained by Dale Dougherty
+and Arnold Robbins in ``sed \& awk'' second edition, pages 112--114.
+
+<<format-def>>=
+#!/bin/sh
+usage()
+{
+  printf 'usage: %s [file.lisp]\n' $0
+  exit 1
+}
+
+sed -E '/^\(defun |\(defmacro /{
+ i\
+
+}' "$@" | \
+sed '/^[ \t]*$/{
+   N
+   /^[ \t]*\n$/D
+}'
+@
+
+When we make a new release of \lp, we like to name its version as the
+tip of the source code repository.  We get the information usually
+with a command line such as 
+%
+\begin{verbatim}
+$ git log --oneline | head -1 | awk '{print $1}'
+52663d1
+\end{verbatim}
+%
+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>>=
+#!/bin/sh
+usage()
+{
+  printf 'usage: %s tag file\n' $0
+  exit 1
+}
+
+test $# -lt 2 && usage
+
+tag="$1"; shift
+sed "/<<Version>>=/ {
+ n;
+ c\\
+$tag
+}" "$@"
+@
 
 \section*{Index of chunks}
 \nowebchunks

make-release

@@ -4,11 +4,12 @@ usage()
   printf 'usage: %s tag file\n' $0
   exit 1
 }
-test $# '<' 2 && usage
+
-tag="$1"
+test $# -lt 2 && usage
-shift
+
-sed "/<<Version>>=/ {
+tag="$1"; shift
+sed "/a89e088=/ {
  n;
  c\\
 $tag
-}" $*
+}" "$@"