Implements LIST {NEWSGROUPS,SUBSCRIPTIONS}

Adds support for TAGS in noweb files.

I really don't know whether the above is complete or not.

Makefile

@@ -5,5 +5,5 @@ loop: loop.asd loop.lisp scripts/build-exe.lisp
 
 install: loop
 	mkdir -p `head -1 conf-home` && \
-		cp -R loop accounts.lisp groups scripts \
+		cp -R loop accounts.lisp index groups scripts \
 			`head -1 conf-home`

Nowebfile

@@ -3,79 +3,81 @@ include Makefile
 
 default: all
 
-all: loop.exe loop.lisp loop.asd scripts/build-exe.lisp \
+all: loop 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
+loop: scripts/build-exe.lisp loop.lisp loop.asd loop.nw
 	sbcl --script scripts/build-exe.lisp
-	(test -f loop.exe && cmp loop loop.exe) || cp loop loop.exe
 
 loop.lisp: loop.nw format-def
-	(any tangle -Rloop.lisp < loop.nw | sh format-def | \
-		dos2unix > loop.tmp || \
+	(no tangle -Rloop.lisp < loop.nw | sh format-def > loop.tmp || \
 		(rm loop.tmp && exit 1)) && \
 		mv loop.tmp loop.lisp
 
 format-def: loop.nw
-	(any tangle -Rformat-def < loop.nw | \
-		dos2unix > format-def.tmp || \
+	(no tangle -Rformat-def < loop.nw > format-def.tmp || \
 		(rm format-def.tmp && exit 1)) && \
-		mv format-def.tmp format-def
+		mv format-def.tmp format-def && \
+			chmod 0755 format-def
 
 make-release: loop.nw
-	(any tangle -Rmake-release < loop.nw | \
-		dos2unix > make-release.tmp || \
+	(no tangle -Rmake-release < loop.nw > make-release.tmp || \
 		(rm make-release.tmp && exit 1)) && \
-		mv make-release.tmp make-release
+		mv make-release.tmp make-release && \
+			chmod 0755 make-release
 
 release: make-release
-	./make-release $$(git log --oneline | head -1 | awk '{print $$1}') \
+	./make-release $$(git log --oneline -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 || \
+	(no tangle -Rloop.asd < loop.nw > loop-asd.tmp || \
 		(rm loop-asd.tmp && exit 1)) && \
 		mv loop-asd.tmp loop.asd
 
 scripts/build-exe.lisp: loop.asd loop.lisp loop.nw
-	(any tangle -Rbuild-exe.lisp < loop.nw | dos2unix > build-exe.tmp || \
+	(no tangle -Rbuild-exe.lisp < loop.nw > build-exe.tmp || \
 		(rm build-exe.tmp && exit 1)) && \
 	    mv build-exe.tmp scripts/build-exe.lisp
 
 scripts/build-index-from-fs.lisp: loop.nw
-	(any tangle -Rbuild-index-from-fs.lisp < loop.nw | dos2unix > \
+	(no tangle -Rbuild-index-from-fs.lisp < loop.nw > \
 		build-index-from-fs.tmp || \
 		(rm build-index-from-fs.tmp && exit 1)) && \
 	    	mv build-index-from-fs.tmp scripts/build-index-from-fs.lisp
 
 scripts/cron-remove-inactive-users.lisp: loop.nw
-	(any tangle -Rcron-remove-inactive-users.lisp < loop.nw | dos2unix > \
+	(no tangle -Rcron-remove-inactive-users.lisp < loop.nw > \
 		cron-remove-inactive-users.tmp || \
 		(rm cron-remove-inactive-users.tmp && exit 1)) && \
 		mv cron-remove-inactive-users.tmp \
 			scripts/cron-remove-inactive-users.lisp
 
 scripts/migrate-add-creation-date.lisp: loop.nw
-	(any tangle -Rmigrate-add-creation-date.lisp < loop.nw | dos2unix > \
+	(no tangle -Rmigrate-add-creation-date.lisp < loop.nw > \
 		migrate-add-creation-date.tmp || \
 		(rm migrate-add-creation-date.tmp && exit 1)) && \
 		mv migrate-add-creation-date.tmp \
 			scripts/migrate-add-creation-date.lisp
 
 run: loop.nw
-	(any tangle -Rrun < loop.nw | dos2unix > run.tmp || \
+	(no tangle -Rrun < loop.nw > run.tmp || \
 		(rm run.tmp && exit 1)) && \
 		mv run.tmp run && \
 		chmod 0755 run
 
 loop.tex: loop.nw
-	any weave -delay -index loop.nw | dos2unix > loop.tex
+	no weave -delay -index loop.nw > loop.tex
 
 loop.pdf: loop.tex
 	latexmk -pdf loop
 
 clean: 
-	rm -f loop loop.exe loop.asd loop.lisp loop.tex loop.pdf \
+	rm -f loop loop.asd loop.lisp loop.tex loop.pdf \
 	  *.fasl *.db .*~ *~ *.out *.aux *.log *.fls *.fdb_latexmk
+
+tags: loop.nw
+	etags -l tex loop.nw
+	etags -a -l lisp loop.nw

README

@@ -71,7 +71,7 @@ $ tcpserver -v -HR 0.0.0.0 1024 ./loop -s
 tcpserver: status: 0/40
 --8<-------------------------------------------------------->8---
 
-Using another terminal, telnet to your host on port 1024:
+Now telnet to your host on port 1024:
 
 --8<-------------------------------------------------------->8---
 $ telnet localhost 1024
@@ -122,6 +122,7 @@ $ crontab -l
 
 We installed LOOP just fine on
 
+  OpenBSD 7.6 with SBCL 2.4.8.openbsd.sbcl-2.4.8.
   FreeBSD 14.1, 14.2 with SBCL 2.4.9.
   Debian GNU/Linux 8.11 codename jessie with SBCL 1.2.4.debian.
 

TAGS

@@ -0,0 +1,290 @@
+
+loop.nw,3549
+\def\nwendcode{\nwendcode
35,939
+\newcommand{\lxxp}\lxxp
39,1017
+\newcommand{\Lp}\Lp
40,1048
+\newcommand{\lp}\lp
41,1077
+\newcommand{\bug}\bug
42,1099
+\newcommand{\symlink}\symlink
43,1128
+\newcommand{\symlinks}\symlinks
44,1171
+  \label{fg:gnus}fg:gnus
81,2706
+  \label{fg:bird}fg:bird
87,2911
+  \label{fg:sylpheed}fg:sylpheed
93,3111
+\ref{fg:gnus}fg:gnus
137,5733
+\section*{*
140,5822
+Section \ref{sec:inactive-users}sec:inactive-users
148,6361
+\section*{*
184,8177
+\section{Implementation strategy}\label{sec:design}Implementation
190,8309
+illustrated in Figures~\ref{fg:gnus}fg:gnus
319,12490
+Section~\ref{sec:repl}sec:repl
323,12759
+\section{NNTP protocol}NNTP
328,12992
+\section{It's a network server}It's
342,13734
+through the command line as illustrated in Section~\ref{sec:design}sec:design
369,15206
+\section{REPL for \lp}\label{sec:repl}REPL
371,15276
+\section{Representation of a client}Representation
437,17374
+\section{Representation of a command}Representation
449,17770
+\section{Representation of requests and responses}Representation
517,20737
+\section{Main loop}Main
594,23947
+\section{Parsing of requests}Parsing
669,25880
+\section{Parsing of command-line arguments}Parsing
688,26641
+\section{Request dispatching mechanism}Request
961,36913
+\section{Representation and parsing of articles}Representation
982,37706
+\section{How to extract articles from the database}How
1065,40809
+\section{Commands}Commands
1115,42605
+\subsection{{\tt HELP}}1117,42625
+\subsection{{\tt AUTHINFO}}\label{sec:authinfo}1151,43910
+Section~\ref{sec:login}sec:login
1157,44202
+\subsection{{\tt CREATE-ACCOUNT}}1202,45894
+\subsection{{\tt UNLOCK-ACCOUNT}}1320,50452
+\ref{sec:inactive-users}sec:inactive-users
1323,50541
+\subsection{{\tt LOGIN}}\label{sec:login}1356,51852
+Besides {\tt AUTHINFO} in Section~\ref{sec:authinfo}sec:authinfo
1358,51895
+\subsection{{\tt PASSWD}}\label{sec:passwd}1384,52856
+\subsection{{\tt USERS}}\label{sec:users}1430,54730
+\subsection{{\tt LIST}}\label{sec:list}1480,56381
+\subsection{{\tt GROUP}}\label{sec:group}1632,62446
+\subsection{{\tt BODY}, {\tt HEAD}, {\tt ARTICLE} e {\tt NEXT}}1662,63270
+\label{sec:typical-cmds}sec:typical-cmds
1663,63334
+Section~\ref{sec:index}sec:index
1673,63902
+\subsection{{\tt XOVER}}\label{sec:xover}1775,68503
+\subsection{{\tt MODE READER}}\label{sec:mode-reader}1833,71074
+\subsection{{\tt DATE}}\label{sec:date}1842,71321
+\subsection{{\tt QUIT}}\label{sec:quit}1855,71664
+\subsection{{\tt DD}}\label{sec:dd}1865,71927
+\subsection{{\tt POST}}\label{sec:post}1878,72420
+\subsection{{\tt CREATE-GROUP}}2241,87684
+\subsection{{\tt REPL}}2278,89424
+\section{Publication of news}Publication
2305,90274
+\section{Algorithm of {\tt split-vector}}Algorithm
2346,91833
+\section{Article index}\label{sec:index}Article
2377,93028
+\section{Essential operations relative to the index}Essential
2457,96627
+\section{Procedure to import the index from the file system}Procedure
2502,98639
+\section{Deletion and locking of inactive accounts}\label{sec:inactive-users}Deletion
2568,100703
+\section{Macros to ease writing}\label{sec:dsl}Macros
2734,107284
+\section{Other procedures}Other
2797,109416
+\section{Tests}Tests
2887,112172
+\section{Executable, how to build it}Executable,
2960,115048
+\section{Log of \lp's communication, how to produce it}Log
2981,115628
+\section{Package {\tt loop.lisp} as the compiler needs it}Package
3018,116977
+\section{Other source code}Other
3118,120026
+\section*{*
3209,123229
+\section*{*
3212,123270
+
+loop.nw,7251
+(defun repl 406,16344
+(defstruct client 444,17635
+(defparameter *client* 445,17707
+(defstruct command 460,18266
+(defparameter *commands-assoc* 461,18306
+(defun table-of-commands 465,18369
+(defun set-up-tables! 490,19679
+(defun get-command 503,20175
+(defstruct request 532,21437
+(defstruct response 533,21472
+(defun empty-response 537,21569
+(defun prepend-response-with 538,21648
+(defun append-crlf-if-needed 549,22038
+(defun send-response! 559,22358
+(defun my-write 588,23770
+(defun main-loop 609,24648
+(defun request-quit? 617,24871
+(defun response-quit? 618,24938
+(defun server-start 620,25011
+(defun main 625,25086
+(defun send-banner! 633,25219
+(defun parse-request 676,26130
+(defun root/command 717,28103
+(defun root/options 726,28330
+(defun root/handlers 745,28781
+(defun root/main 812,31505
+(defun account/command 829,32050
+(defun account/options 836,32217
+(defun account/manager 880,33246
+(defun account/list-accounts 929,35415
+(defun account/create-account! 932,35499
+(defun account/change-passwd! 948,36285
+(defun dispatch 972,37440
+(defun dispatch-line 978,37595
+(defstruct article 1001,38661
+(defun parse-article 1005,38761
+(defun hs-space-collapsed 1017,39117
+(defun hs-lines 1020,39233
+(defun parse-header 1022,39291
+(defun parse-head 1033,39765
+(defun string-integer? 1037,39888
+(defun get-header-from-article 1044,40120
+(defun get-header 1047,40222
+(defun fetch-headers 1051,40328
+(defun enrich-headers 1057,40538
+(defun nlines 1062,40720
+(defun fetch-article 1073,41166
+(defun read-file-raw 1077,41253
+(defun fetch-body 1088,41548
+(defun encode-body 1099,42004
+(defun extract-mid 1109,42415
+(defun lookup 1111,42509
+(defun cmd-help 1132,43409
+(defun menu 1140,43672
+(defun display-fn 1144,43750
+(defun cmd-authinfo 1167,44575
+(defun authinfo-check 1189,45558
+(defun auth? 1192,45627
+(defun log-user-in! 1195,45681
+(defun user-name-conforms? 1222,46556
+(defun cmd-create-account 1226,46661
+(defstruct account 1243,47431
+(defparameter *accounts* 1244,47525
+(defun read-accounts! 1248,47602
+(defun string->array 1256,47799
+(defun string->sha256 1261,47960
+(defun new-account! 1265,48108
+(defun write-accounts! 1298,49724
+(defun get-account 1314,50246
+(defun cmd-unlock-account 1327,50650
+(defun unlock-account! 1344,51440
+(defun cmd-login 1364,52175
+(defun log-user-in-as! 1379,52743
+(defun cmd-passwd 1391,53128
+(defun pass? 1410,54030
+(defun change-passwd! 1421,54453
+(defun cmd-list-users 1436,54874
+(defun size-of-longest-username 1444,55101
+(defun list-users 1448,55216
+(defun universal-to-human 1468,56050
+(defun last-time-seen 1474,56169
+(defstruct group 1490,56831
+(defun cmd-list 1492,56864
+(defun build-groups-lines 1499,57124
+(defun build-groups-structs 1506,57288
+(defun between? 1513,57553
+(defun filesize 1517,57628
+(defun zero-file? 1521,57700
+(defun temporary-article? 1524,57751
+(defun article-ready? 1528,57860
+(defun get-articles 1533,57977
+(defun group-high-low 1543,58365
+(defun articles->integers 1550,58592
+(defun list-groups 1557,58829
+(defun last-char 1562,59026
+(defun basename 1570,59239
+(defun loop-directory* 1591,60259
+(defun loop-list-files 1601,60921
+(defun loop-list-directories 1610,61276
+(defun cmd-group 1637,62577
+(defun group? 1648,62987
+(defun xgroup? 1652,63057
+(defun set-group! 1655,63097
+(defun typical-cmd-head-body-article 1676,63998
+(defun cmd-head 1692,64865
+(defun cmd-body 1694,64938
+(defun cmd-article 1696,65011
+(defun article-response 1699,65091
+(defun head-response 1701,65190
+(defun body-response 1703,65303
+(defun typical-cmd-response 1732,66889
+(defun cmd-next 1753,67671
+(defun article-next! 1764,68125
+(defun mid-by-name 1771,68392
+(defun cmd-xover 1784,68864
+(defun xover 1803,69821
+(defun xover-format-line 1824,70743
+(defun xover-headers 1829,70965
+(defun cmd-mode 1838,71220
+(defun cmd-date 1848,71508
+(defun cmd-quit 1861,71841
+(defun cmd-test 1873,72224
+(defun suggest-message-id 1890,72964
+(defun random-string 1893,73056
+(defun unparse-article 1907,73469
+(defun ensure-header 1924,74079
+(defun get-date 1937,74556
+(defun ensure-mid 1944,74798
+(defun ensure-date 1946,74877
+(defun cmd-post 1974,75958
+(defun post 2009,77527
+(defun newsgroups-header->list 2033,78605
+(defun update-last-post-date! 2048,79301
+(defun rename-no-extension 2066,80230
+(defun save-article-try 2069,80333
+(defun save-article-insist 2103,81607
+(defun get-next-article-id 2109,81828
+(defun nntp-read-article 2125,82527
+(defun nntp-read-line 2144,83403
+(defun list->bytes 2153,83766
+(defun vector->bytes 2156,83820
+(defun data->bytes 2159,83889
+(defun add-crlf-between 2167,84158
+(defun string->bytes 2171,84310
+(defun bytes->string 2174,84365
+(defun conforms? 2194,85304
+(defun text/plain? 2207,85952
+(defun headers-required-from-clients 2216,86295
+(defun cmd-create-group 2251,88133
+(defun group-name-conforms? 2274,89300
+(defun cmd-repl 2284,89577
+(defparameter *enable-nntp-repl* 2302,90234
+(defun notify-group-created 2312,90507
+(defun notify-user-created 2317,90718
+(defun notify-user-unlocked 2322,90916
+(defun post-notification 2328,91133
+(defun make-news 2334,91423
+(defun split-vector 2357,92329
+(defun split-vector-helper 2361,92471
+(defun create-index! 2411,94531
+(defun rm-rf 2414,94595
+(defun drop-create-index! 2417,94676
+(defun insert-index 2477,97606
+(defun lookup-index 2494,98361
+(defun index-from-fs! 2524,99476
+(defun remake-index-from-fs 2533,99889
+(defun remove-inactive-users! 2592,101636
+(defun remove-account! 2628,103539
+(defun lock-account! 2636,103831
+(defun loop-epoch 2652,104565
+(defun migrate-add-creation-and-post-date! 2655,104626
+(defparameter *months-inactive-allowed* 2677,105392
+(defparameter *months-never-logged-in* 2678,105435
+(defun user-inactive? 2682,105521
+(defun inactive-from-never-logged-in? 2686,105647
+(defun locked? 2693,105901
+(defun inactive-from-last-post? 2696,105988
+(defun inactive-from-last-seen? 2704,106346
+(defun inactive-from? 2713,106695
+(defun ever-logged-in? 2721,106902
+(defun never-logged-in? 2724,106978
+(defun list-inactive-users 2727,107050
+(defmacro in-dir 2742,107560
+(defmacro in-groups 2756,108079
+(defun in-group-lambda 2758,108141
+(defmacro in-group 2760,108197
+(defmacro with-group 2763,108297
+(defmacro with-n-args 2773,108619
+(defmacro with-group-set 2783,108996
+(defmacro with-auth 2790,109201
+(defun conforms-to? 2808,109948
+(defun print/finish 2815,110199
+(defun word-plural 2819,110285
+(defun plural 2826,110536
+(defun out 2833,110720
+(defun stderr 2836,110791
+(defun stdout 2841,110917
+(defun println 2844,110993
+(defun enumerate 2847,111105
+(defun ucs-2->ascii 2851,111222
+(defun bad-input 2855,111319
+(defun integer->string 2858,111416
+(defun mkstr 2861,111467
+(defun data 2865,111572
+(defun crlf 2868,111655
+(defun crlf-string 2871,111689
+(defun flatten 2874,111755
+(defmacro mac 2883,112041
+(define-test dispatching2918,113875
+(defun unix->nntp 2921,113970
+(defvar a-post 2925,114082
+(defvar a-bad-post 2933,114231
+(define-test post-wrong-newsgroup2941,114426
+(define-test post-okay2946,114593
+(defpackage #:loop3040,118020
+(defparameter *debug* 3090,119274
+(asdf:defsystem :<<Name>>3111,119857

groups/local.control.news/1

@@ -1,7 +1,7 @@
-Date: 2024-03-07 21:44:31 GMT-3
-Message-Id: <edjocyeqzqqhnswlbrbo@loop>
-From: Loop
-Subject: let there be light
-Newsgroups: local.control.news
-
-Administrative news will be posted here by me. -- Loop
+Date: 2024-03-07 21:44:31 GMT-3
+Message-Id: <edjocyeqzqqhnswlbrbo@loop>
+From: Loop
+Subject: let there be light
+Newsgroups: local.control.news
+
+Administrative news will be posted here by me. -- Loop

loop.asd

@@ -1,6 +1,6 @@
 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*-
 (asdf:defsystem :LOOP
-  :version "a89e088"
+  :version "ec13a0c"
   :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

@@ -5,13 +5,12 @@
      :filesystem-utils :ironclad/digest/sha256)
    :silent t))
 
-(clsql:file-enable-sql-reader-syntax)
-
 (defpackage #:loop
   (:use :common-lisp :local-time)
   (:import-from :lisp-unit define-test assert-true)
   (:import-from :org.shirakumo.filesystem-utils 
-                directory-p list-directories list-files)
+                directory-p list-directories list-files
+                create-symbolic-link)
   (:import-from :sb-sys interactive-interrupt)
   (:export :main))
 
@@ -24,10 +23,9 @@
 (defparameter *client* (make-client))
 (defstruct request verb args said)
 (defstruct response code data request multi-line)
-(defparameter *default-database* nil)
 (defstruct command fn verb description)
 (defparameter *commands-assoc* nil)
-(defstruct article headers body)
+(defstruct article message-id newsgroups headers username body head)
 (defparameter *months-inactive-allowed* 3)
 (defparameter *months-never-logged-in* 1)
 (defparameter *enable-nntp-repl* t)
@@ -51,7 +49,7 @@
                      "creates an account so you can invite a friend")
     ("PASSWD" ,#'cmd-passwd "changes your password")
     ("USERS" ,#'cmd-list-users "lists all users")
-    ("DD" ,#'cmd-dd "[d]isplays [d]ata: your state of affairs")
+    ("TEST" ,#'cmd-test "runs a developer's experiment")
     ("QUIT" ,#'cmd-quit "politely says good-bye")
     ("DATE" ,#'cmd-date "displays the current date at this server")
     ("UNLOCK-ACCOUNT" ,#'cmd-unlock-account "unlocks an account")
@@ -77,7 +75,7 @@
                 :fn #'(lambda (r)
                         (make-response
                          :code 400
-                         :data "unrecognized command"
+                         :data "Unrecognized command."
                          :request r))
                 :verb 'unrecognized
                 :description "a command for all commands typed wrong")))
@@ -102,7 +100,7 @@
            (,r-var ,r))
        (if (not (group? ,g-var))
            (make-response :code 411 :request ,r-var
-                          :data (format nil "no such group ``~a''" ,g-var))
+                          :data (fmt "No such group ``~a''." ,g-var))
            (progn ,@body)))))
 
 (defmacro with-n-args (n r &rest body)
@@ -178,20 +176,20 @@
   (make-response :code (or code 400) :data msg :request r))
 
 (defun integer->string (n)
-  (format nil "~a" n))
+  (fmt "~a" n))
 
-(defun mkstr (&rest args) ;; a utility
+(defun mkstr (&rest args)
   (with-output-to-string (s)
     (dolist (a args) (princ a s))))
 
-(defun data (&rest args) ;; a utility
+(defun data (&rest args)
   (flatten (map 'list #'data->bytes args)))
 
 (defun crlf ()
   (vector 13 10))
 
 (defun crlf-string ()
-  (format nil "~c~c" #\return #\linefeed))
+  (fmt "~c~c" #\return #\linefeed))
 
 (defun flatten (obj)
   (do* ((result (list obj))
@@ -252,7 +250,7 @@
      (append seq 
              (when (not (= (car (last seq)) 10))
                (list 13 10))))
-    (t (error (format nil "append-crlf-if-needed: unsupported type: ~a" (type-of seq))))))
+    (t (error (fmt "append-crlf-if-needed: unsupported type: ~a" (type-of seq))))))
 
 (defun send-response! (r)
   (let ((bs (data (integer->string (response-code r)) " " 
@@ -283,42 +281,26 @@
                              :args args))))))
 
 (defun insert-index (m g i)
-  (handler-case
-      (clsql:insert-records 
-       :into "indices"
-       :attributes '(id grp article) 
-       :values (list (str:trim m) (str:trim g) (str:trim i)))
-    (clsql-sys:sql-database-data-error (c)
-      (cond ((= (slot-value c 'clsql-sys::error-id) 19)
-             'already-indexed)
-            (t
-             ; We should log this error.
-             ;(format t "other error: ~a" (slot-value c 'clsql-sys::database-message))
-             'sql-error)))
-    (:no-error () 
-      nil)))
+  (let ((from (fmt "index/~a" m))
+        (to (fmt "../groups/~a/~a" g i)))
+    (stderr "Creating link from ~a to ~a...~%" from to)
+    (create-symbolic-link from to)))
 
 (defun lookup-index (mid)
-  (let* ((found (clsql:select [grp] [article] 
-                              :from [indices] 
-                              :where [= [id] (str:trim mid)]))
-         (article (first found))
-         (grp (first article))
-         (art (second article)))
-    (when found
-      (values grp art))))
-
-(defun connect-index! (filename)
-  (setq *default-database* (clsql:connect (list filename) :database-type :sqlite3)))
+  (let ((path (ignore-errors (truename (fmt "index/~a" mid)))))
+    (when path
+        (let* ((name (namestring path))
+               (pair (last (str:split "/" name) 2)))
+          (values (car pair) (cadr pair))))))
 
 (defun create-index! ()
-  (clsql:execute-command "create table if not exists indices 
-     (id varchar(1000), grp varchar(1000), article varchar(300))")
-  (clsql:execute-command "create unique index if not exists idx_id_1 
-    on indices (id)"))
+  (ensure-directories-exist "index/"))
+
+(defun rm-rf (path)
+  (uiop:delete-directory-tree (pathname path) :validate t))
 
 (defun drop-create-index! ()
-  (clsql:execute-command "drop table if exists indices")
+  (rm-rf "index/")
   (create-index!))
 
 (defun remove-inactive-users! ()
@@ -453,12 +435,24 @@
   (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))))
+(defun parse-article (v &optional (username nil))
+  (let* ((parts (split-vector (vector 13 10 13 10) v nil :limit 2))
+         (head (car parts))
+         (head-str (map 'string #'code-char head))
+         (headers (parse-head head-str))         
+         (body (cadr parts))
+         (mid (lookup "message-id" headers))
+         (ngs (str:split "," (str:collapse-whitespaces (lookup "newsgroups" headers)))))
+    (make-article
+     :headers headers
+     :message-id mid
+     :newsgroups ngs
+     :username username
+     :head head-str
+     :body body)))
 
 (defun hs-space-collapsed (hs) 
-  (cl-ppcre:regex-replace-all (format nil "~a[ ~a]+" (crlf-string) #\tab) hs " "))
+  (cl-ppcre:regex-replace-all (fmt "~a[ ~a]+" (crlf-string) #\tab) hs " "))
 
 (defun hs-lines (lines) (str:split (crlf-string) lines))
 
@@ -466,23 +460,21 @@
   (let* ((h (str:collapse-whitespaces header))
          (pos (search ":" h)))
     (when (null pos)
-      (throw 'article-syntax-error 
-        (values nil (format nil "missing colon in header |~a|" h))))
+      (throw 'article-syntax-error (values nil (fmt "missing colon in header |~a|" h))))
     (when (<= (length h) (+ 2 pos))
-      (throw 'article-syntax-error
-        (values nil (format nil "empty header ~a" h))))
+      (throw 'article-syntax-error (values nil (fmt "empty header ~a" h))))
     (multiple-value-bind (key val) 
         (values (subseq h 0 pos) (subseq h (+ 2 pos)))
       (cons (str:downcase key) val))))
 
-(defun parse-headers (hs)
+(defun parse-head (hs)
   (let ((ls (hs-lines (hs-space-collapsed hs))))
     (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)))))
+  (get-header h (parse-head (article-head (parse-article a)))))
 
 (defun get-header (key hs) 
   (let ((pair (assoc key hs :test #'string=)))
@@ -491,19 +483,19 @@
 (defun fetch-headers (g i)
   (let* ((a-string (fetch-article g i))
          (a-parsed (parse-article a-string))
-         (headers (parse-headers (article-headers a-parsed))))
+         (headers (parse-head (article-head a-parsed))))
     (enrich-headers headers a-string)))
 
 (defun enrich-headers (hs a)
   (append hs
-    `(("line-count" . ,(format nil "~a" (nlines (article-body (parse-article a)))))
-     ("byte-count" . ,(format nil "~a" (length a))))))
+    `(("line-count" . ,(fmt "~a" (nlines (article-body (parse-article a)))))
+     ("byte-count" . ,(fmt "~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))))
+   (read-file-raw (fmt "~a/~a" g i))))
 
 (defun read-file-raw (path)
   (with-open-file 
@@ -522,7 +514,7 @@
 (defun encode-body (a) a)
 
 (defun extract-mid (a)
-  (lookup "message-id" (parse-headers (article-headers (parse-article a)))))
+  (lookup "message-id" (parse-head (article-head (parse-article a)))))
 
 (defun lookup (key table)
   (cdr (assoc key table :test #'string=)))
@@ -547,7 +539,7 @@
            ((string= cmd "USER")
             (setf (client-username *client*) arg)
             (make-response :code 381 :request r 
-                           :data (format nil "Hey, ~a, please tell us your password." arg)))
+                           :data (fmt "Hey, ~a, please tell us your password." arg)))
            ((string= cmd "PASS")
             (if (authinfo-check (client-username *client*) arg)
                 (progn 
@@ -586,7 +578,7 @@
                            (t (multiple-value-bind (group n-str) (lookup-index n-or-mid)
                                 (if (and group n-str)
                                     (funcall fn-name r group n-str)
-                                    (bad-input r (format nil "Unknown article ~a." n-or-mid))))))))
+                                    (bad-input r (fmt "Unknown article ~a." n-or-mid))))))))
                   (t (bad-input r "No, no: it takes at most two arguments.")))))))
 
 (defun cmd-head (r)
@@ -602,7 +594,7 @@
   (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)))))
+  (typical-cmd-response 221 r g i #'(lambda (a) (article-head (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))))))
@@ -613,16 +605,16 @@
         (cond ((null a) 
                (make-response 
                 :code 400 :request r 
-                :data (format nil "article ~a/~a does not exist" g i)))
+                :data (fmt "article ~a/~a does not exist" g i)))
               (t 
                (prepend-response-with
-                  (format nil "~a ~a" i (extract-mid a))
+                  (fmt "~a ~a" i (extract-mid a))
                   (make-response :multi-line 'yes :code code 
                                  :request r :data (funcall get-data a))))))
     (sb-posix:syscall-error (c)
       (make-response 
        :code 400 :request r 
-       :data (format nil "article ~a/~a: ~a" g i c)))))
+       :data (fmt "article ~a/~a: ~a" g i c)))))
 
 (defun cmd-next (r)
   (with-auth
@@ -640,7 +632,7 @@
   (let ((cur (client-article *client*)))
     (make-response :code 223
                    :request r
-                   :data (format nil "~a ~a" cur (mid-by-name g cur)))))
+                   :data (fmt "~a ~a" cur (mid-by-name g cur)))))
 
 (defun mid-by-name (g name)
   (extract-mid (fetch-article g name)))
@@ -687,7 +679,7 @@
                                     (fetch-headers g i)))))))))))
 
 (defun xover-format-line (i hs)
-  (str:concat (format nil "~a~a" i #\tab)
+  (str:concat (fmt "~a~a" i #\tab)
               (str:join #\tab 
                         (mapcar #'(lambda (h) (get-header h hs))
                                 (xover-headers)))))
@@ -702,7 +694,7 @@
           (with-group g r
             (set-group! g)
             (multiple-value-bind (low high len) (group-high-low g)
-              (let ((ln (format nil "~a ~a ~a ~a" len low high g)))
+              (let ((ln (fmt "~a ~a ~a ~a" len low high g)))
                 (setf (client-article *client*) low)
                 (make-response :code 211 :request r :data ln))))))))
 
@@ -728,7 +720,7 @@
   (reverse
    (mapcar 
     #'(lambda (g) 
-        (format nil "~a ~a ~a y" (group-name g) (group-high g) (group-low g))) 
+        (fmt "~a ~a ~a y" (group-name g) (group-high g) (group-low g))) 
     ls)))
 
 (defun build-groups-structs ()
@@ -847,7 +839,7 @@
 
 (defun display-fn (cmd-pair)
   (let ((cmd (cdr cmd-pair)))
-    (format nil "~A ~A" 
+    (fmt "~A ~A" 
             (command-verb cmd) 
             (command-description cmd))))
 
@@ -860,18 +852,29 @@
                  :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)))))
-      (let ((result (dolist (h (headers-required-from-clients))
-                      (when (not (lookup h headers))
-                        (return (format nil "missing the /~a/ header" h)))))
-            (content-type (get-header "content-type" headers)))
-        (cond 
-          ((stringp result) (values nil result))
-          ((not (text/plain? content-type))
-           (values nil (format nil "content-type must be plain/text, but it's ~a" content-type)))
-          (t (values t nil)))))))
+(defun conforms? (parsed-article)
+  (catch 'article-syntax-error ;; parse-header might throw
+    (let* ((headers (article-headers parsed-article))
+           (required (dolist (h (headers-required-from-clients))
+                       (when (not (lookup h headers))
+                         (return (fmt "missing the /~a/ header" h)))))
+           (content-type (get-header "content-type" headers))
+           (ngs-dont-exist
+            (let ((ls)
+                  (ngs (article-newsgroups parsed-article)))
+              (dolist (g ngs)
+                (if (or (not (group-name-conforms? g)) (not (group? g)))
+                    (push g ls))))))
+      (cond 
+        ((stringp required) (values nil required))
+        ((not (text/plain? content-type))
+         (values nil (fmt "content-type must be plain/text, but it's ~a" content-type)))
+        ((not (zerop (length ngs-dont-exist)))
+         (values nil (fmt "Sorry. We will not post your article to any newsgroup because "
+                          "the " (word-plural (length ngs-dont-exist) "newsgroup") " " 
+                          (str:join ", " (sort ngs-dont-exist #'string<))
+                          " just " (word-plural (length ngs-dont-exist) "doesn't") " exist.")))
+        (t (values t nil))))))
 
 (defun text/plain? (header-s)
   ;; I say T when S begins with "text/plain" or when S is "".
@@ -886,7 +889,7 @@
   '("from" "newsgroups" "subject"))
 
 (defun suggest-message-id (&optional (n 20))
-  (format nil "<~a@loop>" (random-string n)))
+  (fmt "<~a@loop>" (random-string n)))
 
 (defun random-string (size)
   (let* ((universe "abcdefghijklmnopqrstuvwxyz")
@@ -898,80 +901,69 @@
     (coerce mid 'string)))
 
 (defun unparse-article (parsed)
-  (data
-   (let ((ls))
-     (dolist (h (parse-headers (article-headers parsed)))
-       (setq ls (cons (data (str:capitalize (car h)) ": " (cdr h) (crlf)) ls)))
-     (nreverse ls))
-   (crlf)
-   (article-body parsed)))
+  (coerce 
+   (data
+    (let ((ls))
+      (dolist (h (parse-head (article-head parsed)))
+        (setq ls (cons (data (str:capitalize (car h)) ": " (cdr h) (crlf)) ls)))
+      (nreverse ls))
+    (crlf)
+    (article-body parsed))
+   'vector))
 
-(defun ensure-header (h fn bs)
-  (let* ((headers (parse-headers (article-headers (parse-article bs)))))
-    (if (lookup h headers)
-        bs
-        (unparse-article
-         (make-article 
-          :headers 
-          (str:join (crlf-string) 
-                    (mapcar #'(lambda (h)
-                                (format nil "~a: ~a" (car h) (cdr h))) 
-                            (cons (cons h (funcall fn)) headers)))
-          :body (article-body (parse-article bs)))))))
+(defun enrich-article (parsed-article)
+  (ensure-mid (ensure-date parsed-article)))
+
+(defun ensure-mid (parsed-article) 
+  (ensure-header "message-id" #'suggest-message-id parsed-article))
+
+(defun ensure-date (parsed-article) 
+  (ensure-header "date" #'get-date parsed-article))
+
+(defun ensure-header (header fn-add-header parsed-article)
+  (if (lookup header (article-headers parsed-article))
+      parsed-article
+      (progn 
+        (setf (article-headers parsed-article)
+              (cons (cons header (funcall fn-add-header)) 
+                    (article-headers parsed-article)))
+        parsed-article)))
 
 (defun get-date ()
   (multiple-value-bind (s m h day mon year dow dst-p tz)
       (get-decoded-time)
     (declare (ignore dow dst-p))
-    (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d GMT~a"
-            year mon day h m s (- tz))))
-
-(defun ensure-mid (bs)
-  (ensure-header "message-id" #'suggest-message-id bs))
-
-(defun ensure-date (bs)
-  (ensure-header "date" #'get-date bs))
+    (fmt "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d GMT~a"
+         year mon day h m s (- tz))))
 
 (defun cmd-post (r)
   (with-auth 
       (send-response! 
        (make-response 
         :code 340 
-        :data (format nil "Okay, go ahead. Suggested message-id ~a."
+        :data (fmt "Okay, go ahead. Suggested message-id ~a."
                                     (suggest-message-id))))
-    (let* ((bs (nntp-read-article)))
-      (multiple-value-bind (okay? error) (conforms? bs)
+    (let* ((bs (nntp-read-article))
+           (parsed-article (parse-article bs (client-username *client*))))
+      (multiple-value-bind (okay? error) (conforms? parsed-article)
         (cond ((not okay?)
                (make-response 
                 :code 400 :request r
-                :data (format nil "Sorry. Your article doesn't conform: ~a." error)))
-              (t (multiple-value-bind (code reply) (post bs)
+                :data (fmt "Sorry. Your article doesn't conform: ~a." error)))
+              (t 
+               (multiple-value-bind (code reply) (post (enrich-article parsed-article))
                    (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))
-    (dolist (g ngs)
-      (if (or (not (group-name-conforms? g))
-              (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*))))
-          (values 240 (data "Thank you! Your article has been saved.")))
-        (values 400 (data "Sorry. We did not post your article to any newsgroup because "
-                          "the " (word-plural (length ngs-dont-exist) "newsgroup") " " 
-                          (str:join ", " (sort ngs-dont-exist #'string<))
-                          " just " (word-plural (length ngs-dont-exist) "doesn't") " exist.")))))
+(defun post (parsed-article)
+  (let* ((parsed-article (ensure-date (ensure-mid parsed-article)))
+         (bs (unparse-article parsed-article))
+         (ng (car (article-newsgroups parsed-article))))
+    (save-article-insist ng (get-next-article-id ng) bs)
+    (update-last-post-date! (client-username *client*)))
 
-(defun newsgroups-header->list (s)
-  (mapcar #'(lambda (n) (str:trim (string-downcase n))) (str:split "," s)))
+  ;; Now that we've saved the article, it's time to index it.
+
+)
 
 (defun update-last-post-date! (username)
   (let ((u (get-account username)))
@@ -981,8 +973,8 @@
   (rename-file old (make-pathname :name new :type :unspecific)))
 
 (defun save-article-try (name-try bs)
-  (let ((name (format nil "~a" name-try))
-        (tmp (format nil "~a.tmp" name-try)))
+  (let ((name (fmt "~a" name-try))
+        (tmp (fmt "~a.tmp" name-try)))
     (with-open-file 
         (s name 
            :direction :output
@@ -1001,11 +993,11 @@
       (write-sequence bs s))
     (rename-no-extension tmp name)))
 
-(defun save-article-insist (g name a message-id)
+(defun save-article-insist (g name bytes)
   (loop for name from name do
-    (in-dir (format nil "groups/~a/" g)
-            (when (not (eql 'name-exists (save-article-try name a)))
-              (return (values name (insert-index message-id g (fmt "~a" name))))))))
+    (in-dir (fmt "groups/~a/" g)
+            (when (not (eql 'name-exists (save-article-try name bs)))
+              (return name)))))
 
 (defun get-next-article-id (g)
   (multiple-value-bind (low high len) (group-high-low g)
@@ -1040,7 +1032,7 @@
         ((stringp d) (string->bytes d))
         ((consp d) (list->bytes d))
         ((vectorp d) (vector->bytes d))
-        (t (error (format nil "type ~a is not supported" (type-of d))))))
+        (t (error (fmt "type ~a is not supported" (type-of d))))))
 
 (defun add-crlf-between (ls-of-ls)
   ;; Add \r\n to each ``line''. Returns List-of Byte.
@@ -1059,21 +1051,21 @@
           (group-name-conforms? g)
         (if (not okay?)
             (make-response :code 580 :request r 
-                           :data (format nil "group name does not conform: ~a" reason))
+                           :data (fmt "group name does not conform: ~a" reason))
             (progn
               (multiple-value-bind (path created?) 
                   (in-groups (ensure-directories-exist (concatenate 'string g "/")))
                 (declare (ignore created?))
                 (if (not path)
                     (make-response :code 581 :request r
-                                   :data (format nil "could not create group ~a" 
+                                   :data (fmt "could not create group ~a" 
                                                  (if (group? g) 
                                                      "because it already exists" 
                                                      "but we don't know why---sorry!")))
                     (progn
                       (notify-group-created g)
                       (make-response :code 280 :request r
-                                     :data (format nil "group ~a created" g)))))))))))
+                                     :data (fmt "group ~a created" g)))))))))))
 
 (defun group-name-conforms? (g)
   (conforms-to? g "^[^\\s/]+$"))
@@ -1133,21 +1125,19 @@
 
 (defun write-accounts! ()
   (let ((name
-          (loop 
-            (let* ((tmp (random-string 10))
-                   (name (format nil "~a.tmp" tmp)))
-              (when 
-                  (ignore-errors 
-                   (with-open-file 
-                       (s name
-                          :direction :output
-                          :if-exists :error
-                          :if-does-not-exist :create)
-                     (write *accounts* :stream s)))
-                (return name))))))
-    (if (ignore-errors (rename-file name "accounts.lisp"))
-        (values t *accounts*)
-        (values nil (format nil "could not rename ~a to accounts.lisp" name)))))
+          (let* ((tmp (random-string 10))
+                 (name (fmt "~a.tmp" tmp)))
+            (with-open-file 
+                (s name
+                   :direction :output
+                   :if-exists :error
+                   :if-does-not-exist :create)
+              (write *accounts* :stream s)
+              name))))
+    (rename-file name "accounts.lisp")
+    (values t *accounts*)
+    ;(values nil (fmt "could not rename ~a to accounts.lisp" name))
+    ))
 
 (defun get-account (username)
   (loop for u in *accounts*
@@ -1251,23 +1241,24 @@
         maximizing (length (account-username u))))
 
 (defun list-users ()
-  (read-accounts!)
-  (mapcar #'(lambda (row) (cadr row))
-          (sort
-           (loop for u in *accounts* 
-                 collect (list (account-username u) 
-                               (fmt "~v@a~a, ~a, invited ~a" 
-                                    (size-of-longest-username)
-                                    (account-username u)
-                                    (if (locked? (account-username u))
-                                        (fmt " (account locked: ~a)"
-                                             (account-pass-locked-why u))
-                                        "")
-                                    (if (last-time-seen (account-username u))
-                                        (fmt "last seen on ~a" (last-time-seen (account-username u)))
-                                        "never logged in")
-                                    (or (account-friends u) "nobody"))))
-           #'string<= :key #'(lambda (row) (car row)))))
+  (mapcar
+   #'(lambda (row) (cadr row))
+   (sort
+    (loop for u in *accounts* 
+          collect (list
+                   (account-username u) 
+                   (fmt "~v@a~a, ~a, invited ~a" 
+                        (size-of-longest-username)
+                        (account-username u)
+                        (if (locked? (account-username u))
+                            (fmt " (account locked: ~a)"
+                                 (account-pass-locked-why u))
+                          "")
+                        (if (last-time-seen (account-username u))
+                            (fmt "last seen on ~a" (last-time-seen (account-username u)))
+                          "never logged in")
+                        (or (account-friends u) "nobody"))))
+    #'string<= :key #'(lambda (row) (car row)))))
 
 (defun universal-to-human (s)
   (format-timestring
@@ -1280,8 +1271,9 @@
     (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-test (r) 
+  (let ((x (create-symbolic-link "index/<871pw1mm9e.fsf@tor.soy>" "../groups/local.test/15")))
+    (make-response :code 200 :data (fmt "returned: ~a" x) :request r)))
 
 (defun cmd-repl (r)
   (if *enable-nntp-repl*
@@ -1312,58 +1304,164 @@
   (in-groups (ensure-directories-exist "local.control.news/"))
   (when (group? "local.control.news")
     (let ((a (make-news :subject subject :body body)))
-        (post (concatenate 'vector (article-headers a) (crlf) (article-body a) (crlf))))))
+        (post (concatenate 'vector (article-head a) (crlf) (article-body a) (crlf))))))
 
 (defun make-news (&key subject body)
   (make-article 
    :headers (data 
              (add-crlf-between 
               (mapcar 
-               #'(lambda (p) (data (format nil "~a: ~a" (car p) (cdr p))))
+               #'(lambda (p) (data (fmt "~a: ~a" (car p) (cdr p))))
                `(("from" . "Loop")
                  ("subject" . ,subject)
                  ("newsgroups" .  "local.control.news")))))
    :body (data body)))
 
-(defun cli/options () 
+(defun root/command ()
+  (clingon:make-command
+   :name "LOOP"
+   :description "An NNTP server for a circle of friends."
+   :version "ec13a0c"
+   :options (root/options)
+   :handler #'root/handlers
+   :sub-commands (list (account/command))))
+
+(defun root/options () 
   (list 
-   (clingon:make-option
-    :string
-    :description "creates a new account"
-    :long-name "create-account"
-    :key :create-account)
-   (clingon:make-option
-    :string
-    :description "changes password"
-    :long-name "change-passwd"
-    :key :change-passwd)
    (clingon:make-option
     :flag
-    :description "lists accounts"
-    :short-name #\l
-    :long-name "list-accounts"
-    :key :list-accounts)
-   (clingon:make-option
-    :flag
-    :description "runs a REPL right now"
+    :description "action: runs a REPL on the terminal"
     :short-name #\r
     :long-name "repl"
     :key :repl)
    (clingon:make-option
     :flag
-    :description "disables the NNTP REPL"
+    :description "action: disables the NNTP REPL"
     :long-name "disable-nntp-repl"
     :key :disable-nntp-repl)
    (clingon:make-option
     :flag
-    :description "logging (on stderr)"
+    :description "action: logs to stderr"
     :long-name "logging"
     :key :logging)))
 
-(defun cli/list-accounts ()
+(defun root/handlers (cmd)
+  (root/main cmd)
+  ;; (handler-case 
+  ;;     (root/main cmd)
+  ;;   (end-of-file ()
+  ;;     (print/finish "^d~%")
+  ;;     (uiop:quit 0))
+  ;;   (interactive-interrupt ()
+  ;;     (print/finish "^c~%")
+  ;;     (uiop:quit 0)))
+  )
+
+(defun root/main (cmd)
+  (server-start)
+  ;; (let ((args (clingon:command-arguments cmd))
+  ;;       (repl? (clingon:getopt cmd :repl))
+  ;;       (logging? (clingon:getopt cmd :logging))
+  ;;       (disable-nntp-repl? (clingon:getopt cmd :disable-nntp-repl)))
+  ;;   (setq *debug* logging?)
+  ;;   (setq *enable-nntp-repl* (not disable-nntp-repl?))
+  ;;   (when repl? 
+  ;;     (return-from root/main (repl (make-request))))
+  ;;   (server-start))
+  )
+
+(defun account/command ()
+  (clingon:make-command
+   :name "account"
+   :description "manages accounts"
+   :options (account/options)
+   :handler #'account/manager))
+
+(defun account/options () 
+  (list 
+   (clingon:make-option
+    :flag
+    :description "action: creates a new --username account invited by --invited-by"
+    :short-name #\n
+    :long-name "new"
+    :key :new)
+   (clingon:make-option
+    :flag
+    :description "action: lists all accounts"
+    :short-name #\l
+    :long-name "list"
+    :key :list)
+   (clingon:make-option
+    :string
+    :description "action: sets password for --username"
+    :short-name #\p
+    :long-name "password"
+    :key :password)
+   (clingon:make-option
+    :string
+    :description ""
+    :short-name #\u
+    :long-name "username"
+    :key :username)
+   (clingon:make-option
+    :string
+    :description ""
+    :short-name #\i
+    :long-name "invited-by"
+    :key :inviter)
+   (clingon:make-option
+    :flag
+    :description "action: destroys account --username"
+    :short-name #\d
+    :long-name "delete"
+    :key :del?)))
+
+(defun account/manager (cmd)
+  (let ((args (clingon:command-arguments cmd))
+        (new? (clingon:getopt cmd :new))
+        (del? (clingon:getopt cmd :del?))
+        (list? (clingon:getopt cmd :list))
+        (pass (clingon:getopt cmd :password))
+        (user (str:upcase (clingon:getopt cmd :username)))
+        (inviter (clingon:getopt cmd :inviter)))
+    (cond 
+      (pass
+       (cond ((not user)
+              (return-from account/manager 
+                (println "Option --username is required.")))
+             (t (account/change-passwd! user pass)
+                ;(println "Okay, ~a has now password ``~a''" user pass)
+                )))
+      (del? 
+       (cond ((not user)
+              (return-from account/manager 
+                (println "Option --username is required.")))
+             ((not (get-account user))
+              (return-from account/manager
+                (println "Account ~a not found." user)))
+             (t (remove-account! user)
+                (write-accounts!)
+                (println "Account ~a deleted." user))))
+      (new? 
+           (cond ((or (not user) (not inviter))
+                  (return-from account/manager 
+                    (println "Options --username, --invited-by are required.")))
+                 ((not (user-name-conforms? user))
+                  (return-from account/manager
+                    (println "Username ``~a'' doesn't conform to regex /^[^\\s]+$/." user)))
+                 ((not (get-account inviter))
+                  (return-from account/manager
+                    (println "Inviter ~a is not a known account; list'em all with ``account -l''." inviter)))
+                 (t 
+                  (log-user-in-as! inviter)
+                  (account/create-account! user (list inviter)))))
+          (list? (account/list-accounts))
+          (t (println "Nothing to do.  Say --help.")))))
+
+(defun account/list-accounts ()
   (println (str:join (crlf-string) (list-users))))
 
-(defun cli/create-account (username args)
+(defun account/create-account! (username args)
   (let ((invited-by (car args)))
     (cond ((null invited-by)
            (println "Must specify who invites the new account."))
@@ -1379,62 +1477,15 @@
                         (notify-user-created username))
                  (println "Sorry, ~a." pass-or-error)))))))
 
-(defun cli/change-passwd (username args)
+(defun account/change-passwd! (username &optional given-passwd)
   (let* ((random-passwd (random-string 6))
-         (given-passwd (car args))
          (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)          (if okay?
+        (multiple-value-bind (okay? problem) (change-passwd! username new-passwd)   
+       (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)
-    (end-of-file ()
-      (print/finish "^D~%")
-      (uiop:quit 0))
-    (interactive-interrupt ()
-      (print/finish "^C~%")
-      (uiop:quit 0))))
-
-(defun cli/main (cmd)
-  (read-accounts!)
-  (connect-index! "message-id.db")
-  (create-index!)
-  (let ((args (clingon:command-arguments cmd))
-        (run-server t)
-        (repl (clingon:getopt cmd :repl))
-        (ca (clingon:getopt cmd :create-account))
-        (pa (clingon:getopt cmd :change-passwd))
-        (la (clingon:getopt cmd :list-accounts))
-        (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
-      (cli/create-account ca args))
-    (when pa
-      (cli/change-passwd pa args))
-    (when repl
-      (repl (make-request :verb "repl" :args '(command-line))))
-    (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 "a89e088"
-   :license "GPL v3"
-   :options (cli/options)
-   :handler #'cli/main-with-handlers))
+              (println "Sorry, could not change password: ~a." problem)))))) 
 
 (defun main-loop ()
   (loop
@@ -1454,14 +1505,18 @@
   (main-loop))
 
 (defun main ()
-  (let ((app (cli/command)))
-    (clingon:run app)))
+  (read-accounts!)
+  (create-index!)
+  (server-start)
+  ;; (let ((app (root/command)))
+  ;;   (clingon:run app))
+  )
 
 (defun send-banner! ()
   (send-response! 
    (make-response 
     :code 200 
-    :data "Welcome! I am LOOP a89e088. Say ``help'' for a menu.")))
+    :data "Welcome! I am LOOP ec13a0c. Say ``help'' for a menu.")))
 (setq lisp-unit:*print-failures* t)
 (define-test dispatching
   (assert-true (equalp (empty-response) (dispatch (make-request)))))
@@ -1493,7 +1548,6 @@ A bad test from the biggest mouth of the south.
 
 (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))

make-release

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

scripts/build-index-from-fs.lisp

@@ -5,7 +5,6 @@
     (load quicklisp-init)))
 (ql:quickload :loop :silent t)
 (in-package #:loop)
-(connect-index! "message-id.db")
 (drop-create-index!)
 (index-from-fs!)
 (format t "Index built.~%")

scripts/cron-remove-inactive-users.lisp

@@ -6,6 +6,5 @@
 (ql:quickload :loop :silent t)
 (in-package #:loop)
 (read-accounts!)
-(connect-index! "message-id.db")
 (remove-inactive-users!)
 (write-accounts!)