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

@@ -0,0 +1,81 @@
+# -*- mode: makefile -*-
+include Makefile
+
+default: all
+
+all: loop.exe loop.lisp loop.asd scripts/build-exe.lisp \
+scripts/build-index-from-fs.lisp \
+scripts/cron-remove-inactive-users.lisp \
+scripts/migrate-add-creation-date.lisp
+
+loop.exe: scripts/build-exe.lisp loop.lisp loop.asd loop.nw
+	sbcl --script scripts/build-exe.lisp
+	(test -f loop.exe && cmp loop loop.exe) || cp loop loop.exe
+
+loop.lisp: loop.nw format-def
+	(any tangle -Rloop.lisp < loop.nw | sh format-def | \
+		dos2unix > loop.tmp || \
+		(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)) && \
+		mv loop-asd.tmp loop.asd
+
+scripts/build-exe.lisp: loop.asd loop.lisp loop.nw
+	(any tangle -Rbuild-exe.lisp < loop.nw | dos2unix > build-exe.tmp || \
+		(rm build-exe.tmp && exit 1)) && \
+	    mv build-exe.tmp scripts/build-exe.lisp
+
+scripts/build-index-from-fs.lisp: loop.nw
+	(any tangle -Rbuild-index-from-fs.lisp < loop.nw | dos2unix > \
+		build-index-from-fs.tmp || \
+		(rm build-index-from-fs.tmp && exit 1)) && \
+	    	mv build-index-from-fs.tmp scripts/build-index-from-fs.lisp
+
+scripts/cron-remove-inactive-users.lisp: loop.nw
+	(any tangle -Rcron-remove-inactive-users.lisp < loop.nw | dos2unix > \
+		cron-remove-inactive-users.tmp || \
+		(rm cron-remove-inactive-users.tmp && exit 1)) && \
+		mv cron-remove-inactive-users.tmp \
+			scripts/cron-remove-inactive-users.lisp
+
+scripts/migrate-add-creation-date.lisp: loop.nw
+	(any tangle -Rmigrate-add-creation-date.lisp < loop.nw | dos2unix > \
+		migrate-add-creation-date.tmp || \
+		(rm migrate-add-creation-date.tmp && exit 1)) && \
+		mv migrate-add-creation-date.tmp \
+			scripts/migrate-add-creation-date.lisp
+
+run: loop.nw
+	(any tangle -Rrun < loop.nw | dos2unix > run.tmp || \
+		(rm run.tmp && exit 1)) && \
+		mv run.tmp run && \
+		chmod 0755 run
+
+loop.tex: loop.nw
+	any weave -delay -index loop.nw | dos2unix > loop.tex
+
+loop.pdf: loop.tex
+	latexmk -pdf loop
+
+clean: 
+	rm -f loop loop.exe loop.asd loop.lisp loop.tex loop.pdf \
+	  *.fasl *.db .*~ *~ *.out *.aux *.log *.fls *.fdb_latexmk

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))
+    :CREATION 3913066800))

format-def

@@ -0,0 +1,15 @@
+#!/bin/sh
+usage()
+{
+  printf 'usage: %s [file.lisp]\n' $0
+  exit 1
+}
+
+sed -E '/^\(defun |\(defmacro /{
+ i\
+
+}' "$@" | \
+sed '/^[ \t]*$/{
+   N
+   /^[ \t]*\n$/D
+}'

loop.asd

@@ -1,6 +1,6 @@
 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*-
-(asdf:defsystem :loop
+(asdf:defsystem :LOOP
-  :version "0.1"
+  :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,21 @@
 
 (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") 
     ("NEXT" ,#'cmd-next "increments the article pointer")
@@ -80,6 +82,7 @@
                 :verb 'unrecognized
                 :description "a command for all commands typed wrong")))
       (or (cdr cmd) (unrecognized-command)))))
+
 (defmacro in-dir (dir &rest body)
   `(let ((*default-pathname-defaults* (truename ,dir)))
      (uiop:with-current-directory (,dir)
@@ -90,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))
@@ -124,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 ""))
 
@@ -187,6 +204,7 @@
 
 (defmacro mac (&rest body)
   `(macroexpand-1 ,@body))
+
 (defun repl (r)
   (in-package :loop)
   (loop
@@ -216,13 +234,16 @@
          "Oops: ~a~%" 
          (str:collapse-whitespaces 
           (str:replace-all (string #\linefeed) " " (fmt "~a" c))))))))
+
 (defun empty-response () (make-response :code 400 :data "I beg your pardon?"))
+
 (defun prepend-response-with (message r)
   (make-response 
    :code (response-code r) 
    :data (data message (crlf) (response-data r))
    :multi-line (response-multi-line r)
    :request (response-request r)))
+
 (defun append-crlf-if-needed (seq)
   (cond 
     ((stringp seq)
@@ -244,10 +265,12 @@
       (stderr ">>> ~a" (bytes->string (ucs-2->ascii bs)))))
   (force-output)
   r)
+
 (defun my-write (ls-of-bytes s)
   (if (interactive-stream-p s)
       (write-sequence (mapcar #'code-char ls-of-bytes) s)
       (write-sequence ls-of-bytes s)))
+
 (defun parse-request (r)
   (let* ((collapsed-s (str:collapse-whitespaces (request-said r)))
          (ls (str:split " " collapsed-s :omit-nulls 'please)))
@@ -258,6 +281,7 @@
                (make-request :said (request-said r)
                              :verb (str:upcase verb)
                              :args args))))))
+
 (defun insert-index (m g i)
   (handler-case
       (clsql:insert-records 
@@ -283,6 +307,7 @@
          (art (second article)))
     (when found
       (values grp art))))
+
 (defun connect-index! (filename)
   (setq *default-database* (clsql:connect (list filename) :database-type :sqlite3)))
 
@@ -295,10 +320,10 @@
 (defun drop-create-index! ()
   (clsql:execute-command "drop table if exists indices")
   (create-index!))
+
 (defun remove-inactive-users! ()
   (loop for u in *accounts* do
     (let ((username (account-username u)))
-      (format t "Username: ~a~%" username)
       (cond ((and (not (locked? username))
                   (inactive-from-never-logged-in? username))
              (post-notification 
@@ -319,6 +344,7 @@
                             (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
         (setf (account-friends u)
@@ -332,6 +358,7 @@
     (setf (account-pass-locked u) (account-pass u))
     (setf (account-pass u) "locked")
     (setf (account-pass-locked-why u) why)))
+
 (defun user-inactive? (username)
   (or (inactive-from-never-logged-in? username)
       (inactive-from-last-seen? username)))
@@ -382,6 +409,7 @@
         (format t "Username ~a is inactive? ~a~%" 
                 (account-username u)
                 (user-inactive? (account-username u)))))
+
 (defun loop-epoch ()
   (encode-timestamp 0 0 0 0 1 1 2024))
 
@@ -392,6 +420,7 @@
                (setf (account-creation u) (timestamp-to-universal (loop-epoch)))
                (setf (account-last-post u) (account-seen u))))
   (write-accounts!))
+
 (defun split-vector (delim v acc &key limit (so-far 1))
   (let ((len (length v)))
     (split-vector-helper delim v len acc limit so-far 0)))
@@ -410,6 +439,7 @@
                   limit
                   (1+ so-far)
                   (+ pos (length delim))))))))
+
 (defun index-from-fs! ()
   (loop for path in (in-groups (directory "**/*"))
         do (let* ((g (str:trim (first (last (pathname-directory path)))))
@@ -422,6 +452,7 @@
 (defun remake-index-from-fs ()
   (drop-create-index!)
   (index-from-fs!))
+
 (defun parse-article (v)
   (let ((parts (split-vector (vector 13 10 13 10) v nil :limit 2)))
     (make-article :headers (map 'string #'code-char (car parts)) :body (cadr parts))))
@@ -449,6 +480,7 @@
     (mapcar #'(lambda (h) (parse-header h)) ls)))
 
 (defun string-integer? (s) (ignore-errors (parse-integer s)))
+
 (defun get-header-from-article (h a)
   (get-header h (parse-headers (article-headers (parse-article a)))))
 
@@ -468,6 +500,7 @@
      ("byte-count" . ,(format nil "~a" (length a))))))
 
 (defun nlines (v) (length (split-vector (crlf) v nil)))
+
 (defun fetch-article (g i)
   (in-groups
    (read-file-raw (format nil "~a/~a" g i))))
@@ -485,11 +518,15 @@
 
 (defun fetch-body (g i)
   (article-body (parse-article (fetch-article g i))))
+
 (defun encode-body (a) a)
+
 (defun extract-mid (a)
   (lookup "message-id" (parse-headers (article-headers (parse-article a)))))
+
 (defun lookup (key table)
   (cdr (assoc key table :test #'string=)))
+
 (defun dispatch (r)
   (let* ((verb (request-verb r)))
     (if (null verb)
@@ -498,6 +535,7 @@
 
 (defun dispatch-line (ln)
   (dispatch (parse-request (make-request :said ln))))
+
 (defun cmd-authinfo (r) 
   (let* ((args (mapcar #'str:upcase (request-args r))))
     (cond 
@@ -531,8 +569,10 @@
   (let ((u (get-account (client-username *client*))))
     (setf (account-seen u) (get-universal-time)))
   (write-accounts!))
+
 (defun cmd-mode (r) ;; Whatever.
   (make-response :code 200 :request r :data "Sure thing."))
+
 (defun typical-cmd-head-body-article (r fn-name)
   (with-auth
       (with-group-set
@@ -551,17 +591,22 @@
 
 (defun cmd-head (r)
   (typical-cmd-head-body-article r #'head-response))
+
 (defun cmd-body (r)
   (typical-cmd-head-body-article r #'body-response))
+
 (defun cmd-article (r)
   (typical-cmd-head-body-article r #'article-response))
 
 (defun article-response (r g i)
   (typical-cmd-response 220 r g i #'(lambda (a) (encode-body a))))
+
 (defun head-response (r g i)
   (typical-cmd-response 221 r g i #'(lambda (a) (article-headers (parse-article a)))))
+
 (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)
   (handler-case 
       (let ((a (fetch-article g i)))
@@ -578,6 +623,7 @@
       (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*))
@@ -598,6 +644,7 @@
 
 (defun mid-by-name (g name)
   (extract-mid (fetch-article g name)))
+
 (defun cmd-xover (r)
   (with-auth
       (with-group-set
@@ -638,13 +685,16 @@
                                         (member (car h) (xover-headers) 
                                                 :test #'string=))
                                     (fetch-headers g i)))))))))))
+
 (defun xover-format-line (i hs)
   (str:concat (format nil "~a~a" i #\tab)
               (str:join #\tab 
                         (mapcar #'(lambda (h) (get-header h hs))
                                 (xover-headers)))))
+
 (defun xover-headers ()
   '("subject" "from" "date" "message-id" "references" "line-count" "byte-count"))
+
 (defun cmd-group (r)
   (with-auth
       (with-n-args 1 r
@@ -658,7 +708,7 @@
 
 (defun group? (g) 
   (in-groups
-   (directory-p g)))
+   (ignore-errors (directory-p g))))
 
 (defun xgroup? (g) 
   (directory-p g))
@@ -715,7 +765,7 @@
   #+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))
@@ -776,11 +826,13 @@
           #'string-lessp)))
 
 (defun last-char (s) (char s (1- (length s))))
+
 (defun basename (path)
   (let ((s (str:collapse-whitespaces path)))
     (if (char= #\/ (last-char s))
         (car (last (pathname-directory s)))
         (file-namestring s))))
+
 (defun cmd-help (r)
   (let ((lines (menu *commands-assoc*)))
     (prepend-response-with 
@@ -788,23 +840,26 @@
      (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)))
     (format nil "~A ~A" 
             (command-verb cmd) 
             (command-description cmd))))
+
 (defun cmd-quit (r)
   (make-response :code 205 :data "Good-bye." :request r))
+
 (defun cmd-date (r)
   (make-response :code 201
                  :request r
                  :data 
                  (format-timestring nil (now))))
+
 (defun conforms? (bs)
   (catch 'article-syntax-error ;; parse-headers might throw
     (let ((headers (parse-headers (article-headers (parse-article bs)))))
@@ -829,6 +884,7 @@
 
 (defun headers-required-from-clients ()
   '("from" "newsgroups" "subject"))
+
 (defun suggest-message-id (&optional (n 20))
   (format nil "<~a@loop>" (random-string n)))
 
@@ -840,6 +896,7 @@
     (dotimes (c size)
       (setq mid (cons (char universe (random len state)) mid)))
     (coerce mid 'string)))
+
 (defun unparse-article (parsed)
   (data
    (let ((ls))
@@ -848,6 +905,7 @@
      (nreverse ls))
    (crlf)
    (article-body parsed)))
+
 (defun ensure-header (h fn bs)
   (let* ((headers (parse-headers (article-headers (parse-article bs)))))
     (if (lookup h headers)
@@ -856,8 +914,8 @@
          (make-article 
           :headers 
           (str:join (crlf-string) 
-                    (mapcar (lambda (h)
+                    (mapcar #'(lambda (h)
-                              (format nil "~a: ~a" (car h) (cdr h))) 
+                                (format nil "~a: ~a" (car h) (cdr h))) 
                             (cons (cons h (funcall fn)) headers)))
           :body (article-body (parse-article bs)))))))
 
@@ -870,49 +928,55 @@
 
 (defun ensure-mid (bs)
   (ensure-header "message-id" #'suggest-message-id bs))
+
 (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 
-                      :data (format nil "Okay, go ahead. Suggested message-id ~a."
+        :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)))
-          (progn 
+          (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."
+                          (str:join ", " (sort ngs-dont-exist #'string<))
-                          (when ngs-dont-exist
+                          " just " (word-plural (length ngs-dont-exist) "doesn't") " exist.")))))
-                            (data " However, the groups "
+
-                                  (str:join ", " (sort ngs-dont-exist #'string<))
+(defun newsgroups-header->list (s)
-                                  " just don't exist.")))))))
+  (mapcar #'(lambda (n) (str:trim (string-downcase n))) (str:split "," s)))
+
 (defun update-last-post-date! (username)
   (let ((u (get-account username)))
     (setf (account-last-post u) (get-universal-time))))
+
 (defun rename-no-extension (old new)
   (rename-file old (make-pathname :name new :type :unspecific)))
 
@@ -936,6 +1000,7 @@
            :element-type '(unsigned-byte 8))
       (write-sequence bs s))
     (rename-no-extension tmp name)))
+
 (defun save-article-insist (g name a message-id)
   (loop for name from name do
     (in-dir (format nil "groups/~a/" g)
@@ -946,12 +1011,14 @@
   (multiple-value-bind (low high len) (group-high-low g)
     (declare (ignore low len))
     (1+ high)))
+
 (defun nntp-read-article (&optional acc)
   ;; Returns List-of Byte.
   (let* ((ls (ucs-2->ascii (nntp-read-line))))
     (cond ;; 46 == (byte #\.)
       ((equal (list 46) ls) (flatten (add-crlf-between acc))) 
       (t (nntp-read-article (append acc (list ls)))))))
+
 (defun nntp-read-line (&optional (s *standard-input*) acc)
   ;; Returns List-of Byte.
   (let ((x (read-byte s)))
@@ -977,13 +1044,14 @@
 
 (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))
 
 (defun bytes->string (ls)
   (map 'string #'code-char ls))
+
 (defun cmd-create-group (r)
   (with-n-args 1 r
     (let ((g (string-downcase (car (request-args r)))))
@@ -1008,10 +1076,11 @@
                                      :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 
       (with-n-args 1 r
@@ -1026,6 +1095,7 @@
                   (make-response :code 200 :request r
                                  :data (fmt "Okay, account ~a created with password ``~a''."
                                             username pass-or-error)))))))))
+
 (defun read-accounts! ()
   (let ((*package* (find-package '#:loop)))
     (with-open-file 
@@ -1048,14 +1118,19 @@
          (p (random-string 6))
          (a (make-account :username u
                           :pass (string->sha256 (str:upcase p))
-                          :creation (get-universal-time)))) 
+                          :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?)
-          (push u (account-friends (get-account invited-by)))
+             (values nil (fmt "username must conform to ^[^\\s]+$")))
-          (push a *accounts*)
+            ((get-account u)
-          (write-accounts!)
+             (values nil (fmt "account ~a already exists" u)))
-          (values (str:upcase username) p)))))
+            (t
+              (push u (account-friends (get-account invited-by)))
+              (push a *accounts*)
+              (write-accounts!)
+              (values (str:upcase username) p))))))
+
 (defun write-accounts! ()
   (let ((name
           (loop 
@@ -1078,6 +1153,7 @@
   (loop for u in *accounts*
         do (when (string= (str:upcase username) (account-username u))
              (return u))))
+
 (defun cmd-unlock-account (r)
   (with-auth 
       (with-n-args 1 r
@@ -1105,6 +1181,7 @@
            (setf (account-pass u) (account-pass-locked u))
            (setf (account-pass-locked u) nil)
            (setf (account-pass-locked-why u) nil)))))
+
 (defun cmd-login (r) 
   (let* ((args (mapcar #'str:upcase (request-args r))))
     (cond 
@@ -1123,6 +1200,7 @@
 (defun log-user-in-as! (name)
   (setf (client-username *client*) name)
   (log-user-in!))
+
 (defun cmd-passwd (r) 
   (with-auth
       (let* ((args (mapcar #'str:upcase (request-args r))))
@@ -1146,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)))
@@ -1173,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) 
@@ -1188,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
@@ -1200,11 +1279,18 @@
   (let ((u (get-account username)))
     (if u (let ((s (account-seen u)))
             (if s (universal-to-human s))))))
+
 (defun cmd-dd (r) 
   (make-response :code 200 :data (format nil "state: ~a" *client*) :request r))
+
 (defun cmd-repl (r)
-  (with-auth
+  (if *enable-nntp-repl*
-      (repl r)))
+      (with-auth
+          (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 
@@ -1233,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")))))
@@ -1243,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
@@ -1259,15 +1345,21 @@
     :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)"
     :long-name "logging"
     :key :logging)))
+
 (defun cli/list-accounts ()
   (println (str:join (crlf-string) (list-users))))
 
@@ -1293,10 +1385,10 @@
          (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))))))
+
 (defun cli/main-with-handlers (cmd)
   (handler-case 
       (cli/main cmd)
@@ -1312,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
@@ -1326,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 "0.1"
+   :version "a89e088"
    :license "GPL v3"
    :options (cli/options)
    :handler #'cli/main-with-handlers))
@@ -1347,6 +1445,7 @@
           (return))))))
 
 (defun request-quit? (r) (and r (string= 'quit (request-verb r))))
+
 (defun response-quit? (r) (and r (request-quit? (response-request r))))
 
 (defun server-start ()
@@ -1360,23 +1459,44 @@
 
 (defun send-banner! ()
   (send-response! 
-   (make-response :code 200 :data "Welcome! Say ``help'' for a menu.")))
+   (make-response 
-
+    :code 200 
+    :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))

make-release

@@ -0,0 +1,15 @@
+#!/bin/sh
+usage()
+{
+  printf 'usage: %s tag file\n' $0
+  exit 1
+}
+
+test $# -lt 2 && usage
+
+tag="$1"; shift
+sed "/a89e088=/ {
+ n;
+ c\\
+$tag
+}" "$@"