From 2b5a21310ad02c8425dd09146b3ffd42fa175b7c Mon Sep 17 00:00:00 2001 From: Circling Skies Date: Thu, 5 Dec 2024 19:03:09 -0300 Subject: [PATCH] Makes lots of changes. (See full log.) - Converts Makefile to UNIX line termination. Makefiles cannot be formatted with DOS CRLF because, otherwise, we could not escape \n to continue on a second line. We end up escaping \r and not \n. - Fixes remove-account! Procedure delete-if ``may modify sequence'', but we cannot be sure it will modify it. There are cases in which it does and there are cases in which it doesn't. Seeing it did modify in one case, I incorrectly assumed it would modify in all cases---such is life. Since I do want to modify it always, I wrote delete-if*, which in calls setf to be sure the list is overwritten. - Avoids (load'ing "~/.sbclrc") and, instead, does what Quicklisp does. It's not always the case that ~/.sbclrc exists. But Quicklisp in each installation knows what to do. So we do what Quicklisp does in each script that we use. - Frees us from using sb-ext:{file-exists,file-does-not-exist} Turns out SBCL 1.2.4.debian doesn't have these symbols. - Adds command-line parsing. - Adds install target to Makefile. - Rewrites Makefile with a new strategy. - Adds the daemon-tls/ service example. - Adds the daemon service example. - Convers all text files to LF instead of CRLF. --- Makefile | 87 +- README | 160 ++ build-exe.lisp | 5 - build-index-from-fs.lisp | 7 - cron-remove-inactive-users.lisp | 8 - daemon-tls/README | 4 + daemon-tls/log/run | 3 + daemon-tls/run | 7 + daemon/log/run | 3 + daemon/run | 4 + groups/local.control.news/1 | 14 +- groups/local.control.news/2 | 7 - groups/local.control.news/3 | 7 - groups/local.control.news/4 | 7 - groups/local.control.news/5 | 7 - groups/local.control.news/6 | 7 - groups/local.control.news/7 | 7 - groups/local.test/1 | 14 +- groups/local.test/1.~1~ | 7 - loop.asd | 21 +- loop.lisp | 2524 ++++++++++++----------- loop.nw | 598 ++++-- peat | 224 -- scripts/build-exe.lisp | 10 + scripts/build-index-from-fs.lisp | 11 + scripts/cron-remove-inactive-users.lisp | 11 + scripts/migrate-add-creation-date.lisp | 9 + 27 files changed, 2011 insertions(+), 1762 deletions(-) create mode 100644 README delete mode 100644 build-exe.lisp delete mode 100644 build-index-from-fs.lisp delete mode 100644 cron-remove-inactive-users.lisp create mode 100644 daemon-tls/README create mode 100644 daemon-tls/log/run create mode 100644 daemon-tls/run create mode 100644 daemon/log/run create mode 100644 daemon/run delete mode 100644 groups/local.control.news/2 delete mode 100644 groups/local.control.news/3 delete mode 100644 groups/local.control.news/4 delete mode 100644 groups/local.control.news/5 delete mode 100644 groups/local.control.news/6 delete mode 100644 groups/local.control.news/7 delete mode 100644 groups/local.test/1.~1~ delete mode 100644 peat create mode 100644 scripts/build-exe.lisp create mode 100644 scripts/build-index-from-fs.lisp create mode 100644 scripts/cron-remove-inactive-users.lisp create mode 100644 scripts/migrate-add-creation-date.lisp diff --git a/Makefile b/Makefile index 1dbc8dc..c344f88 100644 --- a/Makefile +++ b/Makefile @@ -1,79 +1,8 @@ -SHELL=/bin/sh -REMOTE=dbastos@antartida.xyz -REMOTE_LIB_PATH=quicklisp/local-projects -REMOTE_EXE_PATH=loop-test -SERVICE_NAME=loop-test - -default: - @echo "Sorry. You need to read the Makefile to know what I can make for you." - -all: loop.lisp build-exe.lisp exe run \ -migrate-add-creation-date.lisp cron-remove-inactive-users.lisp - -live: all remote-copy # remote-build-exe - -remote-copy: - scp loop.asd loop.lisp \ - $(REMOTE):$(REMOTE_LIB_PATH)/loop - scp build-exe.lisp \ - $(REMOTE):$(REMOTE_EXE_PATH)/ - scp migrate-add-creation-date.lisp \ - $(REMOTE):$(REMOTE_EXE_PATH)/ - scp cron-remove-inactive-users.lisp \ - $(REMOTE):$(REMOTE_EXE_PATH)/ - -sync-users: - scp $(REMOTE):$(REMOTE_EXE_PATH)/accounts.lisp . - -remote-build-exe: - plink -ssh $(REMOTE) cd $(REMOTE_EXE_PATH)/ && \ - sbcl --script build-exe.lisp && \ - echo "Executable built." - -remote-migrate-account-creation: - plink -ssh $(REMOTE) cd $(REMOTE_EXE_PATH)/ && \ - sbcl --script migrate-add-creation-date.lisp - -remote-cron-remove-inactive-users: - plink -ssh $(REMOTE) cd $(REMOTE_EXE_PATH)/ && \ - sbcl --script remote-cron-remove-inactive-users.lisp - -livedoc: - echo loop.nw | python peat -C 'make loop.pdf' - -run: loop.nw - (any tangle -Rrun < loop.nw > run.tmp || (rm run.tmp && exit 1)) && \ - mv run.tmp run.lisp && \ - chmod 0755 run - -loop.tex: loop.nw - any weave -delay -index loop.nw > loop.tex - -loop.pdf: loop.tex - latexmk -pdf loop - -loop.lisp: loop.nw - (any tangle -Rloop.lisp < loop.nw > loop.tmp || (rm loop.tmp && exit 1)) && \ - mv loop.tmp loop.lisp - -build-exe.lisp: loop.nw - (any tangle -Rbuild-exe.lisp < loop.nw > build-exe.tmp || (rm build-exe.tmp && exit 1)) && \ - mv build-exe.tmp build-exe.lisp - -build-index-from-fs.lisp: loop.nw - (any tangle -Rbuild-index-from-fs.lisp < loop.nw > build-index-from-fs.tmp || (rm build-index-from-fs.tmp && exit 1)) && \ - mv build-index-from-fs.tmp build-index-from-fs.lisp - -cron-remove-inactive-users.lisp: loop.nw - (any tangle -Rcron-remove-inactive-users.lisp < loop.nw > cron-remove-inactive-users.tmp || (rm cron-remove-inactive-users.tmp && exit 1)) && \ - mv cron-remove-inactive-users.tmp cron-remove-inactive-users.lisp - -migrate-add-creation-date.lisp: loop.nw - (any tangle -Rmigrate-add-creation-date.lisp < loop.nw > migrate-add-creation-date.tmp || (rm migrate-add-creation-date.tmp && exit 1)) && \ - mv migrate-add-creation-date.tmp migrate-add-creation-date.lisp - -exe: loop.lisp build-exe.lisp - sbcl --script build-exe.lisp && echo "Executable built okay." - -service: run - sudo ln -s $(pwd) /service/$(SERVICE_NAME) +default: loop + +loop: loop.asd loop.lisp scripts/build-exe.lisp + sbcl --script scripts/build-exe.lisp + +install: loop + mkdir -p `head -1 conf-home` && \ + cp -R loop accounts.lisp groups scripts `head -1 conf-home` diff --git a/README b/README new file mode 100644 index 0000000..fca621b --- /dev/null +++ b/README @@ -0,0 +1,160 @@ +(*) Introduction + +LOOP is an NNTP server written in Common Lisp. + +(*) Assumptions + +We assume + + - you run SBCL + + - you have Quicklisp installed and knows how to use it + + - you know how to use a TCP server such as + + https://cr.yp.to/ucspi-tcp.html + + - you know how to manage a daemon with + + https://cr.yp.to/daemontools.html + + - you have git and knows how to use it + +(*) How to install it + +LOOP is not in the Quicklisp repository, so we'll instruct you to +install it as a local project. Go to + + ~/quicklisp/local-projects/ + +and say + + $ git clone https://git.antartida.xyz/loop/srv loop + $ cd loop + $ echo /path/to/loop/home > conf-home + $ make install + +If you just installed SBCL and quicklisp, the build might take a +little while due to downloading dependencies. Be patient. + +(*) 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. + +--8<-------------------------------------------------------->8--- +$ cd /path/to/loop/home +$ ./loop --help +NAME: + loop - An NNTP server for a circle of friends. + +USAGE: + loop [options] [arguments ...] + +OPTIONS: + --change-passwd changes password + --create-account creates a new account + --help display usage information and exit + --logging turn on debug logging on stderr + --version display version and exit + -l, --list-accounts lists accounts + -r, --repl run a REPL on port 4006 + -s, --server runs NNTP server reading from stdout + +AUTHORS: + Circling Skies + +LICENSE: + GPL v3 +--8<-------------------------------------------------------->8--- + +You can talk to the NNTP server with -s: + +--8<-------------------------------------------------------->8--- +$ ./loop -s +200 Welcome! Say ``help'' for a menu. +quit +205 Good-bye. +--8<-------------------------------------------------------->8--- + +It's time to create an account for you. Whenever you run loop, make +sure you're in its home directory because it will look for the file +accounts.lisp always relatively to the current working directory of +the process. The same applies if you set up a cron job later +on---make sure the job, too, sets LOOP's home directory as its current +working directory. + +(*) Create your account + +LOOP requires authentication for most things, so you should create an +account for you right away. Accounts are kept in accounts.lisp in +your installation directory. Every time you create an account, you +must specify who is inviting this new account into the loop---because +we keep a tree of accounts. The root account is called anonymous, so +your first account must be invited by the anonymous account. So you +can say + + ./loop --create-account you anonymous + +The anonymous account has no special power; it exists solely because +the graph of accounts needs a root. + +(*) How to expose LOOP to the network + +Run your TCP server of choice. For instance, if you're using djb's +tcpserver and would like LOOP to listen on port 1024, tell your shell + +--8<-------------------------------------------------------->8--- +$ tcpserver -v -HR 0.0.0.0 1024 ./loop -s +tcpserver: status: 0/40 +--8<-------------------------------------------------------->8--- + +Using another terminal, telnet to your host on port 1024: + +--8<-------------------------------------------------------->8--- +$ telnet localhost 1024 +Trying 127.0.0.1... +Connected to antartida.xyz. +Escape character is '^]'. +200 Welcome! Say ``help'' for a menu. +quit +205 Good-bye. +Connection closed by foreign host. +--8<-------------------------------------------------------->8--- + +Directories daemon/ and daemon-tls/ in LOOP's source code have sample +scripts to use with djb's tcpserver and daemontools. If you have +never done this, it will be better education if you learn to use +daemontools and ucspi-tcp before going live with a LOOP community. +It's easy and fun. + +(*) Cron jobs + +If you'd like to remove inactive accounts, we wrote +scripts/cron-remove-inactive-users.lisp. Her's our crontab: + +$ crontab -l +@daily cd /path/to/loop/home && sbcl --script scripts/cron-remove-inactive-users.lisp diff --git a/build-exe.lisp b/build-exe.lisp deleted file mode 100644 index cf687f8..0000000 --- a/build-exe.lisp +++ /dev/null @@ -1,5 +0,0 @@ -(load "~/.sbclrc") -(ql:quickload :loop :silent t) -(sb-ext:save-lisp-and-die #P"loop.exe" - :toplevel #'loop:main - :executable t) diff --git a/build-index-from-fs.lisp b/build-index-from-fs.lisp deleted file mode 100644 index 531c769..0000000 --- a/build-index-from-fs.lisp +++ /dev/null @@ -1,7 +0,0 @@ -(load "~/.sbclrc") -(ql:quickload :loop :silent t) -(in-package #:loop) -(connect-index! "message-id.db") -(remake-index!) -(index-from-fs!) -(format t "Index built.~%") diff --git a/cron-remove-inactive-users.lisp b/cron-remove-inactive-users.lisp deleted file mode 100644 index 788c1ba..0000000 --- a/cron-remove-inactive-users.lisp +++ /dev/null @@ -1,8 +0,0 @@ -(load "~/.sbclrc") -(ql:quickload :loop :silent t) -(in-package #:loop) -;; (format t *default-pathname-defaults*) -(read-accounts!) -(connect-index! "message-id.db") -(remove-inactive-users!) -(write-accounts!) diff --git a/daemon-tls/README b/daemon-tls/README new file mode 100644 index 0000000..223c5b5 --- /dev/null +++ b/daemon-tls/README @@ -0,0 +1,4 @@ +In this service example, we're using tlswrapper by Jan Mojžíš, the +source of which you can find at + + https://github.com/janmojzis/tlswrapper diff --git a/daemon-tls/log/run b/daemon-tls/log/run new file mode 100644 index 0000000..35cbcbc --- /dev/null +++ b/daemon-tls/log/run @@ -0,0 +1,3 @@ +#!/bin/sh +echo loop-tls-logger +exec /usr/bin/logger -i -t loop-tls diff --git a/daemon-tls/run b/daemon-tls/run new file mode 100644 index 0000000..53b02ef --- /dev/null +++ b/daemon-tls/run @@ -0,0 +1,7 @@ +#!/bin/sh +echo loop-tls +cd /path/to/loop +exec tcpserver -HR 0.0.0.0 563 \ + /usr/bin/tlswrapper -f \ + /usr/local/etc/letsencrypt/live/mydomain/cert-priv1.pem \ + /path/to/loop diff --git a/daemon/log/run b/daemon/log/run new file mode 100644 index 0000000..e1fa04a --- /dev/null +++ b/daemon/log/run @@ -0,0 +1,3 @@ +#!/bin/sh +echo loop-log +exec /usr/bin/logger -i -t loop diff --git a/daemon/run b/daemon/run new file mode 100644 index 0000000..45a3537 --- /dev/null +++ b/daemon/run @@ -0,0 +1,4 @@ +#!/bin/sh +echo loop +cd /path/to/your/loop +exec /path/to/tcpserver -HR 0.0.0.0 119 /path/to/your/loop diff --git a/groups/local.control.news/1 b/groups/local.control.news/1 index adc869e..81d2d97 100644 --- a/groups/local.control.news/1 +++ b/groups/local.control.news/1 @@ -1,7 +1,7 @@ -Date: 2024-03-07 21:44:31 GMT-3 -Message-Id: -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: +From: Loop +Subject: let there be light +Newsgroups: local.control.news + +Administrative news will be posted here by me. -- Loop diff --git a/groups/local.control.news/2 b/groups/local.control.news/2 deleted file mode 100644 index 8fb0618..0000000 --- a/groups/local.control.news/2 +++ /dev/null @@ -1,7 +0,0 @@ -Date: 2024-12-05 07:27:01 GMT-3 -Message-Id: -From: Loop -Subject: account HIMMEL removed by Loop -Newsgroups: local.control.news - -HIMMEL didn't log in a first time (for 1 month) since account creation. diff --git a/groups/local.control.news/3 b/groups/local.control.news/3 deleted file mode 100644 index 9efd2e1..0000000 --- a/groups/local.control.news/3 +++ /dev/null @@ -1,7 +0,0 @@ -Date: 2024-12-05 07:52:39 GMT-3 -Message-Id: -From: Loop -Subject: account HIMMEL removed by Loop -Newsgroups: local.control.news - -HIMMEL didn't log in a first time (for 1 month) since account creation. diff --git a/groups/local.control.news/4 b/groups/local.control.news/4 deleted file mode 100644 index 5108f91..0000000 --- a/groups/local.control.news/4 +++ /dev/null @@ -1,7 +0,0 @@ -Date: 2024-12-05 07:52:39 GMT-3 -Message-Id: -From: Loop -Subject: account MFELIX locked by Loop -Newsgroups: local.control.news - -MFELIX disappeared for over 3 months. diff --git a/groups/local.control.news/5 b/groups/local.control.news/5 deleted file mode 100644 index 6b578e6..0000000 --- a/groups/local.control.news/5 +++ /dev/null @@ -1,7 +0,0 @@ -Date: 2024-12-05 07:52:39 GMT-3 -Message-Id: -From: Loop -Subject: account KIMOCHI locked by Loop -Newsgroups: local.control.news - -KIMOCHI disappeared for over 3 months. diff --git a/groups/local.control.news/6 b/groups/local.control.news/6 deleted file mode 100644 index ffe4546..0000000 --- a/groups/local.control.news/6 +++ /dev/null @@ -1,7 +0,0 @@ -Date: 2024-12-05 07:52:39 GMT-3 -Message-Id: -From: Loop -Subject: account WILLIAMP locked by Loop -Newsgroups: local.control.news - -WILLIAMP disappeared for over 3 months. diff --git a/groups/local.control.news/7 b/groups/local.control.news/7 deleted file mode 100644 index a1f976f..0000000 --- a/groups/local.control.news/7 +++ /dev/null @@ -1,7 +0,0 @@ -Date: 2024-12-05 07:52:39 GMT-3 -Message-Id: -From: Loop -Subject: account JPMAB locked by Loop -Newsgroups: local.control.news - -JPMAB disappeared for over 3 months. diff --git a/groups/local.test/1 b/groups/local.test/1 index 3aaf4f9..ae3d03f 100644 --- a/groups/local.test/1 +++ b/groups/local.test/1 @@ -1,7 +1,7 @@ -Date: 2024-03-07 21:44:31 GMT-3 -Message-Id: -From: Loop -Subject: let there be light -Newsgroups: local.test - -A sample group. +Date: 2024-03-07 21:44:31 GMT-3 +Message-Id: +From: Loop +Subject: let there be light +Newsgroups: local.test + +A sample group. diff --git a/groups/local.test/1.~1~ b/groups/local.test/1.~1~ deleted file mode 100644 index 014728f..0000000 --- a/groups/local.test/1.~1~ +++ /dev/null @@ -1,7 +0,0 @@ -Date: 2024-03-07 21:44:31 GMT-3 -Message-Id: -From: Loop -Subject: let there be light -Newsgroups: local.control.news - -A sample group. diff --git a/loop.asd b/loop.asd index 3b6a768..3015c42 100644 --- a/loop.asd +++ b/loop.asd @@ -1,14 +1,7 @@ -;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*- -(asdf:defsystem :loop - :version "0.1" - :description "An NNTP server written in Lisp for a circle of friends." - :depends-on (:lisp-unit - :str - :uiop - :cl-fad - :cl-ppcre - :local-time - :iterate - :clsql-sqlite3) - :components ((:file "loop"))) - +;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*- +(asdf:defsystem :loop + :version "0.1" + :description "An NNTP server for a circle of friends." + :depends-on (:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon + :filesystem-utils) + :components ((:file "loop"))) diff --git a/loop.lisp b/loop.lisp index 4ea3067..6ecd0cb 100644 --- a/loop.lisp +++ b/loop.lisp @@ -1,1194 +1,1330 @@ -;;; -*- mode: LISP; syntax: COMMON-LISP; package: LOOP; -*- -(eval-when (:compile-toplevel :load-toplevel :execute) - (ql:quickload - '(:lisp-unit - :str - :uiop - :cl-fad - :cl-ppcre - :local-time - :iterate - :clsql-sqlite3) - :silent t)) - -(clsql:enable-sql-reader-syntax) - -(defpackage #:loop - (:use :common-lisp :local-time) - (:import-from :lisp-unit define-test) - (:import-from :iterate iter) - (:export :main)) - -(in-package #:loop) - -(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 - :subject (fmt "account ~a removed by Loop" username) - :body (fmt "~a didn't log in a first time (for ~a month~a) since account creation." - username *months-never-logged-in* - (plural *months-never-logged-in* "s"))) - (remove-account! username) - (format t "Removed ~a due to never logging in.~%" username)) - ((and (not (locked? username)) - (inactive-from-last-seen? username)) - (post-notification - :subject (fmt "account ~a locked by Loop" username) - :body (fmt "~a disappeared for over ~a month~a." - username *months-inactive-allowed* - (plural *months-inactive-allowed* "s"))) - (lock-account! username - (fmt "disappeared for over ~a months" - *months-inactive-allowed*)) - (format t "Locked ~a due to long-time-no-see.~%" username)))))) - -(defun remove-account! (username) - (loop for u in *accounts* do - (delete-if #'(lambda (x) (equal x username)) (account-friends u))) - (delete-if #'(lambda (x) (equal username (account-username x))) *accounts*)) - -(defun lock-account! (username why) - (let ((u (get-account username))) - (setf (account-pass-locked u) (account-pass u)) - (setf (account-pass u) "locked") - (setf (account-pass-locked-why u) why))) - -(defun remove-friend (username friend) - (remove-if #'(lambda (x) (equal x friend)) - (account-friends (get-account username)))) -(defparameter *months-inactive-allowed* 3) -(defparameter *months-never-logged-in* 1) - -(defun user-inactive? (username) - (or (inactive-from-never-logged-in? username) - (inactive-from-last-seen? username))) - -(defun inactive-from-never-logged-in? (username) - (let ((u (get-account username))) - (if (ever-logged-in? username) - NIL - (inactive-from? username *months-never-logged-in* - #'(lambda () (account-creation u)))))) - -(defun locked? (username) - (equal "locked" (account-pass (get-account username)))) - -(defun inactive-from-last-post? (username) - (let ((last-post (account-last-post (get-account username))) - (creation (account-creation (get-account username)))) - (inactive-from? username *months-inactive-allowed* - (if last-post - #'(lambda () last-post) - #'(lambda () creation))))) - -(defun inactive-from-last-seen? (username) - (let* ((u (get-account username)) - (last-seen (account-seen u)) - (creation (account-creation u))) - (inactive-from? username *months-inactive-allowed* - (if last-seen - #'(lambda () last-seen) - #'(lambda () creation))))) - -(defun inactive-from? (username months timestamp-source) - (timestamp< - (timestamp+ - (universal-to-timestamp - (funcall timestamp-source)) months :month) - (now))) - -(defun ever-logged-in? (username) - (account-seen (get-account username))) - -(defun never-logged-in? (username) - (not (ever-logged-in? username))) - -(defun list-inactive-users () - (loop for u in *accounts* do - (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)) - -(defun migrate-add-creation-and-post-date! () - (read-accounts!) - (loop for u in *accounts* - do (if (not (account-creation u)) - (setf (account-creation u) (timestamp-to-universal (loop-epoch))) - (setf (account-last-post u) (account-seen u)))) - (write-accounts!)) -(defvar *default-database* nil) -(defun connect-index! (filename) - (setq *default-database* (clsql:connect (list filename) :database-type :sqlite3))) - -(defun create-index! () - (clsql:execute-command "create table if not exists indices - (id varchar(1000), grp varchar(1000), article varchar(300))") - (clsql:execute-command "create unique index if not exists idx_id_1 - on indices (id)")) - -(defun remake-index! () - (clsql:execute-command "drop table if exists indices") - (create-index!)) -(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))) - -(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 plural (v suffix) - (if (> v 1) "s" "")) - -(defun debug? () nil) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun fmt (cstr &rest args) - (apply #'format nil (list* cstr args)))) - -(defun stderr (&rest args) - (when (debug?) - (apply #'format (cons *error-output* args)))) - -(defun enumerate (ls &optional (first-index 0)) - (loop for e in ls and i from first-index - collect (cons i e))) - -(defun ucs-2->ascii (bs) - ;; I'm a Windows user. - #-win32 bs #+win32 (remove-if #'zerop bs)) - -(defun bad-input (r msg &key code) - (make-response :code (or code 400) :data msg :request r)) - -(defun integer->string (n) - (format nil "~a" n)) - -(defun mkstr (&rest args) ;; a utility - (with-output-to-string (s) - (dolist (a args) (princ a s)))) - -(defun data (&rest args) ;; a utility - (flatten (map 'list #'data->bytes args))) - -(defun crlf () - (vector 13 10)) - -(defun crlf-string () - (format nil "~c~c" #\return #\linefeed)) - -(defun flatten (obj) - (do* ((result (list obj)) - (node result)) - ((null node) (delete nil result)) - (cond ((consp (car node)) - (when (cdar node) (push (cdar node) (cdr node))) - (setf (car node) (caar node))) - (t (setf node (cdr node)))))) - -(defmacro mac (&rest body) - `(macroexpand-1 ,@body)) -(defmacro in-dir (dir &rest body) - `(let ((*default-pathname-defaults* (truename ,dir))) - (uiop:with-current-directory (,dir) - ,@body))) - -(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))) - -(defmacro with-group (g r &rest body) - (let ((g-var (gensym)) - (r-var (gensym))) - `(let ((,g-var ,g) - (,r-var ,r)) - (if (not (group? ,g-var)) - (make-response :code 411 :request ,r-var - :data (format nil "no such group ``~a''" ,g-var)) - (progn ,@body))))) - -(defmacro with-n-args (n r &rest body) - (let ((args-var (gensym)) - (message-var (gensym)) - (n-var n)) - `(let ((,args-var (request-args r)) - (,message-var ,(fmt "bad arguments: needs exactly ~a" n-var))) - (if (not (= ,n-var (length ,args-var))) - (make-response :code 400 :request ,r :data ,message-var) - (progn ,@body))))) - -(defmacro with-group-set (&rest body) - (let ((g-var (gensym))) - `(let ((,g-var (client-group *client*))) - (if (not ,g-var) - (bad-input r "must say GROUP first") - ,@body)))) - -(defmacro with-auth (&rest body) - `(if (not (auth?)) - (make-response :code 400 :data "You must authenticate first.") - (progn ,@body))) - -(defstruct client group (article 1) (username "ANONYMOUS") (auth? 'no)) -(defparameter *client* (make-client)) -(defstruct command fn verb description) -(defparameter *commands-assoc* nil) - -(defun table-of-commands () - `(("GROUP" ,#'cmd-group "sets the current group") - ("NEXT" ,#'cmd-next "increments the article pointer") - ("HELP" ,#'cmd-help "displays this menu") - ("LIST" ,#'cmd-list "lists all groups") - ("AUTHINFO" ,#'cmd-authinfo "makes me trust you") - ("LOGIN" ,#'cmd-login "shorter interface to AUTHINFO") - ("HEAD" ,#'cmd-head "fetches article headers") - ("MODE" ,#'cmd-mode "handles the mode request from clients") - ("BODY" ,#'cmd-body "fetches an article body") - ("POST" ,#'cmd-post "posts your article") - ("ARTICLE" ,#'cmd-article "fetches full articles") - ("XOVER" ,#'cmd-xover "fetches the overview database of a group") - ("CREATE-GROUP" ,#'cmd-create-group - "creates a new group so you can discuss your favorite topic") - ("CREATE-ACCOUNT",#'cmd-create-account - "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") - ("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"))) - -(defun set-up-tables! () - (labels ((build-commands-assoc (ls) - (if (null ls) - nil - (cons (apply #'make-command-pair (car ls)) - (build-commands-assoc (cdr ls))))) - (make-command-pair (name fn desc) - (cons name (make-command :fn fn :verb name :description desc)))) - (setf *commands-assoc* - (sort - (build-commands-assoc (table-of-commands)) - #'string-lessp :key #'car)))) - -(defun get-command (key) - (let ((cmd (assoc key *commands-assoc* :test #'string=))) - (labels ((unrecognized-command () - (make-command :fn #'(lambda (r) - (make-response :code 400 - :data "unrecognized command" - :request r)) - :verb 'unrecognized - :description "a command for all commands typed wrong"))) - (or (cdr cmd) (unrecognized-command))))) -(defstruct request verb args said) -(defstruct response code data request multi-line) - -(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) - (append-crlf-if-needed (string->bytes seq))) - ((listp seq) - (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)))))) - -(defun send-response! (r) - (let ((bs (data (integer->string (response-code r)) " " - (append-crlf-if-needed (response-data r))))) - (my-write bs *standard-output*) - (stderr ">>> ~a" (bytes->string (ucs-2->ascii bs)))) - (when (response-multi-line r) - (let ((bs (data "." (crlf)))) - (my-write bs *standard-output*) - (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))) - ;; What are we going to do with a null request? - (cond ((null ls) (make-request :said (request-said r))) - (t (let ((verb (car ls)) - (args (cdr ls))) - (make-request :said (request-said r) - :verb (str:upcase verb) - :args args)))))) -(defun main-loop () - (let* ((bs (nntp-read-line)) - (ln (bytes->string (ucs-2->ascii bs)))) - (if ln - (let ((r (send-response! (dispatch-line ln)))) - (when (not (response-quit? r)) - (main-loop))) - (progn - (stderr "eof~%") - 'eof)))) - -(defun request-quit? (r) (and r (string= 'quit (request-verb r)))) -(defun response-quit? (r) (and r (request-quit? (response-request r)))) - -(defun main () - (send-banner!) - (set-up-tables!) - (read-accounts!) - (connect-index! "message-id.db") - (create-index!) - (main-loop)) - -(defun send-banner! () - (send-response! - (make-response :code 200 :data "Welcome! Say ``help'' for a menu."))) -(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))) - -(defun split-vector-helper (delim v len acc limit so-far start) - (if (zerop len) - acc - (let ((pos (search delim v :start2 start :end2 len))) - (cond ((or (not pos) (and limit (= so-far limit))) - (nreverse (cons (subseq v start len) acc))) - (t (split-vector-helper - delim - v - len - (cons (subseq v start (or pos len)) acc) - limit - (1+ so-far) - (+ pos (length delim)))))))) -(defstruct article headers body) - -(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 hs-space-collapsed (hs) - (cl-ppcre:regex-replace-all (format nil "~a[ ~a]+" (crlf-string) #\tab) hs " ")) - -(defun hs-lines (lines) (str:split (crlf-string) lines)) - -(defun parse-header (header) - (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)))) - (when (<= (length h) (+ 2 pos)) - (throw 'article-syntax-error - (values nil (format nil "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) - (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))))) - -(defun get-header (key hs) - (let ((pair (assoc key hs :test #'string=))) - (if pair (cdr pair) ""))) - -(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)))) - (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)))))) - -(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)))) - -(defun read-file-raw (path) - (let* ((size (sb-posix:stat-size (sb-posix:stat path))) - (a (make-array size))) - (with-open-file (in path :element-type '(unsigned-byte 8)) - (read-sequence a in) - a))) - -(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) - (empty-response) - (funcall (command-fn (get-command verb)) r)))) - -(defun dispatch-line (ln) - (dispatch (parse-request (make-request :said ln)))) -(defun cmd-authinfo (r) - (let* ((args (mapcar #'str:upcase (request-args r)))) - (cond - ((not (= (length args) 2)) - (bad-input r "No, no: I take exactly two arguments.")) - (t - (multiple-value-bind (cmd arg) (apply #'values args) - (cond - ((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))) - ((string= cmd "PASS") - (if (authinfo-check (client-username *client*) arg) - (progn - (log-user-in!) - (make-response - :code 281 :request r - :data (fmt "Welcome, ~a." (client-username *client*)))) - (make-response :code 400 :request r :data "Sorry. Wrong password."))) - (t (make-response :code 400 :request r :data "Syntax error. Say ``authinfo USER /your-name/'' then ``authinfo PASS /your-pass/''.")))))))) - -(defun authinfo-check (username passwd) - (pass? username passwd)) - -(defun auth? () - (eq 'yes (client-auth? *client*))) - -(defun log-user-in! () - (setf (client-auth? *client*) 'yes) - (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 - (let ((args (request-args r))) - (cond ((null args) - (funcall fn-name r (client-group *client*) (client-article *client*))) - ((= 1 (length args)) - (let* ((n-or-mid (car args))) - (cond ((string-integer? n-or-mid) - (funcall fn-name r (client-group *client*) n-or-mid)) - (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)))))))) - (t (bad-input r "No, no: it takes at most two arguments."))))))) - -(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) - (let ((a (handler-case (fetch-article g i) - (sb-posix:syscall-error (c) - (make-response :code 400 :request r - :data (format nil "article ~a/~a: ~a" g i c))) - (sb-ext:file-does-not-exist (c) - (declare (ignore c)) - (make-response :code 400 :request r - :data (format nil "article ~a/~a does not exist" g i)))))) - (cond ((typep a 'response) a) - (t (prepend-response-with - (format nil "~a ~a" i (extract-mid a)) - (make-response :multi-line 'yes :code code - :request r :data (funcall get-data a))))))) -(defun cmd-next (r) - (with-auth - (let ((g (client-group *client*)) - (n-cur (client-article *client*))) - (cond - ((not g) (bad-input :code 412 r "must say GROUP first")) - (t (multiple-value-bind (low high len) (group-high-low g) - (declare (ignore low len)) - (cond ((= n-cur high) (bad-input r "you are at the last article already")) - (t (article-next! r g))))))))) - -(defun article-next! (r g) - (setf (client-article *client*) (1+ (client-article *client*))) - (let ((cur (client-article *client*))) - (make-response :code 223 - :request r - :data (format nil "~a ~a" cur (mid-by-name g cur))))) - -(defun mid-by-name (g name) - (extract-mid (fetch-article g name))) -(defun cmd-xover (r) - (with-auth - (with-group-set - (let ((args (request-args r))) - (cond ((null args) - (xover r (client-article *client*) (client-article *client*))) - ((= 1 (length args)) - (multiple-value-bind (s v) - (cl-ppcre:scan-to-strings "([0-9]+)([-]?)([0-9]*)" (car args)) - (cond - ((not s) (make-response :code 502 :request r :data "bad syntax")) - (t (let ((fr (parse-integer (aref v 0))) - (hifen (aref v 1)) - (to (ignore-errors (parse-integer (aref v 2))))) - (when (not (string= hifen "-")) - (setq to fr)) - (xover r fr to)))))) - (t (make-response :code 502 :request r :data "bad syntax"))))))) - -(defun xover (r from to) - (assert (client-group *client*)) - (let* ((g (client-group *client*)) - (ls (get-articles g from to))) - (cond ((= 0 (length ls)) - (make-response :code 420 :request r :data "no articles in the range")) - (t - (prepend-response-with - "Okay, your overview follows..." - (make-response - :code 224 :request r :multi-line 'yes - :data (str:join - (crlf-string) - (loop for i in ls - collect (xover-format-line - i - (remove-if-not - #'(lambda (h) - (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 - (let ((g (car (request-args r)))) - (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))) - (setf (client-article *client*) low) - (make-response :code 211 :request r :data ln)))))))) - -(defun group? (g) - (in-groups - (cl-fad:directory-exists-p g))) - -(defun xgroup? (g) - (cl-fad:directory-exists-p g)) - -(defun set-group! (g) - (setf (client-group *client*) g)) -(defstruct group name high low) - -(defun cmd-list (r) - (prepend-response-with - "Get in the loop! Lots to choose from." - (make-response :code 215 :multi-line 'yes - :data (str:join (crlf-string) (build-groups-lines (build-groups-structs))) - :request r))) - -(defun build-groups-lines (ls) - (reverse - (mapcar - #'(lambda (g) - (format nil "~a ~a ~a y" (group-name g) (group-high g) (group-low g))) - ls))) - -(defun build-groups-structs () - (let ((ret-ls nil)) - (dolist (g (list-groups) ret-ls) - (multiple-value-bind (low high len) (group-high-low g) - (declare (ignore len)) - (setf ret-ls (cons (make-group :name g :high high :low low) ret-ls)))))) - -(defun between? (x from to) - (<= from x to)) -(declaim (inline between?)) - -(defun filesize (path) - (sb-posix:stat-size - (sb-posix:stat path))) - -(defun zero-file? (path) - (= (filesize path) 0)) - -(defun temporary-article? (path) - (or (zero-file? path) - (cl-ppcre:scan "\.tmp$" (namestring path)))) - -(defun article-ready? (path) - (not (temporary-article? path))) - -(defun get-articles (g &optional from to) - (in-groups ;; We might want to optimize this some day. Most likely, - ;; though, we'll not be using directories. That's a - ;; problem to be studied. - (let ((as (articles->integers - (remove-if #'temporary-article? (cl-fad:list-directory g))))) - (sort (remove-if-not - #'(lambda (x) (between? x (or from x) (or to x))) - as) - #'<)))) - -(defun group-high-low (g) - (let* ((articles (get-articles g)) - (sorted-ints (sort articles #'<))) - (values (or (car sorted-ints) 0) - (or (car (last sorted-ints)) 0) - (length sorted-ints)))) - -(defun articles->integers (ls) - (remove-if #'null - (mapcar #'(lambda (g) - (ignore-errors - (parse-integer (basename (uiop:unix-namestring g))))) - ls))) - -(defun list-groups () - (let ((groups (in-groups (cl-fad:list-directory ".")))) - (sort (mapcar #'(lambda (g) (basename (uiop:unix-namestring g))) groups) - #'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 - "What's on the menu today?" - (make-response :code 200 :multi-line 'yes - :request r - :data (str:join (crlf-string) lines))))) -(defun menu (ls) - (if (null ls) - nil - (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))))) - (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 text/plain? (header-s) - ;; I say T when S begins with "text/plain" or when S is "". - (let* ((s (str:collapse-whitespaces header-s)) - (needle "text/plain") - (len (min (length needle) (length s)))) - (or (zerop len) - (and (<= (length needle) (length s)) - (string= needle s :end1 len :end2 len))))) - -(defun headers-required-from-clients () - '("from" "newsgroups" "subject")) -(defun suggest-message-id (&optional (n 20)) - (format nil "<~a@loop>" (random-string n))) - -(defun random-string (size) - (let* ((universe "abcdefghijklmnopqrstuvwxyz") - (len (length universe)) - (state (make-random-state t)) - mid) - (dotimes (c size) - (setq mid (cons (char universe (random len state)) mid))) - (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))) -(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 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)) -(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 - :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?) - (make-response :code 400 :request r - :data (format nil "Sorry. Your article doesn't conform: ~a." error)) - (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) - (dolist (ng ngs) - (if (and (group-name-conforms? ng) - (group? ng)) - (progn - (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))) - (if (zerop (- (length ngs) (length ngs-dont-exist))) - (values 400 "Sorry. There was not a single valid newsgroup specified.") - (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."))))))) -(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))) - -(defun save-article-try (name-try bs) - (let ((name (format nil "~a" name-try)) - (tmp (format nil "~a.tmp" name-try))) - (with-open-file - (s name - :direction :output - :if-exists :error ;; an atomic operation - :if-does-not-exist :create)) - ;(format t "save-article-try: ~a~%" name) - (with-open-file - (s tmp - :direction :output - :if-exists :error - :if-does-not-exist :create - :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) - (handler-case - (save-article-try name a) - (sb-ext:file-exists () - ;; We might want to log the fact. - ;(format t "name ~a already exists...~%" name) - ) - (:no-error (new before after) ;; the return values from return-file - (declare (ignore new before after)) - (return (values name (insert-index message-id g (fmt "~a" name))))))))) - -(defun get-next-article-name (g) - (format nil "~a" (get-next-article-id g))) - -(defun get-next-article-id (g) - (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))) - (cond ((or (null x) (= x 10)) - (let ((bs (and acc (nreverse (if (= (car acc) 13) (cdr acc) acc))))) - (stderr "<<< ~a~%" (bytes->string (ucs-2->ascii bs))) - bs)) - (t (nntp-read-line s (cons x acc)))))) - -(defun list->bytes (ls) - (mapcar #'data->bytes ls)) - -(defun vector->bytes (v) - (mapcar #'data->bytes (coerce v 'list))) - -(defun data->bytes (d) - (cond ((null d) nil) - ((integerp d) (list d)) - ((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)))))) - -(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)) - -(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))))) - (multiple-value-bind (okay? reason) - (group-name-conforms? g) - (if (not okay?) - (make-response :code 580 :request r - :data (format nil "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" - (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))))))))))) - -(defun group-name-conforms? (g) - (let ((okay? (cl-ppcre:scan-to-strings "^([a-z0-9]+)" g))) - (if okay? - (values t nil) - (values nil "must match ^([a-z0-9]+)")))) -(defun cmd-create-account (r) - (with-auth - (with-n-args 1 r - (let* ((args (mapcar #'str:upcase (request-args r))) - (username (car args))) - (multiple-value-bind (username pass-or-error) (new-account! username) - (if (not username) - (make-response :code 400 :request r - :data (fmt "~a. Choose a new name." pass-or-error)) - (progn - (notify-user-created username) - (make-response :code 200 :request r - :data (fmt "Okay, account ~a created with password ``~a''." - username pass-or-error))))))))) - -(defparameter *accounts* nil) -(defstruct account username seen last-post friends pass pass-locked pass-locked-why creation) - -(defun read-accounts! () - (let ((*package* (find-package '#:loop))) - (with-open-file - (s "accounts.lisp" - :direction :input) - (setq *accounts* (read s)))) - *accounts*) - -(defun new-account! (username) - (let* ((u (str:upcase username)) - (p (random-string 6)) - (a (make-account :username u - :pass (sxhash (str:upcase p)) - :creation (get-universal-time)))) - (if (get-account u) - (values nil (fmt "account ~a already exists" u)) - (let ((c (get-account (client-username *client*)))) - (push u (account-friends c)) - (push a *accounts*) - (write-accounts!) - (values (str:upcase username) p))))) -(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))))) - -(defun get-account (username) - (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 - (let* ((args (mapcar #'str:upcase (request-args r))) - (username (car args))) - (cond ((not (get-account username)) - (make-response :code 400 :request r - :data "No such account ~a." username)) - ((not (locked? username)) - (make-response :code 400 :request r - :data (fmt "Can't unlock ~a because it's not locked." username))) - (t - (unlock-account! username) - (notify-user-unlocked username) - (make-response :code 200 :request r - :data (fmt "Okay, account ~a unlocked." username)))))))) - -(defun unlock-account! (username) - (let ((u (get-account username))) - (cond ((not u) - (values nil "no such account")) - ((not (locked? username)) - (values nil "account isn't locked")) - (t - (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 - ((not (= (length args) 2)) - (bad-input r "Usage: login your-username your-password")) - (t - (multiple-value-bind (name pass) (apply #'values args) - (cond - ((pass? name pass) - (log-user-in-as! name) - (make-response :code 200 :request r - :data (fmt "Welcome, ~a." name))) - (t (make-response :code 400 :request r - :data (fmt "Wrong password."))))))))) - -(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)))) - (cond - ((not (= (length args) 2)) - (bad-input r "Usage: passwd current-password new-password")) - (t - (multiple-value-bind (cur new) (apply #'values args) - (cond - ((pass? (client-username *client*) cur) - (multiple-value-bind (okay? problem) (change-passwd! (client-username *client*) new) - (if okay? - (make-response :code 200 :request r - :data "You got it. Password changed.") - (make-response :code 500 :request r - :data (fmt "Sorry: ~a" problem))))) - (t (make-response :code 400 :request r - :data (fmt "Sorry. Wrong password.")))))))))) - -(defun pass? (username pass) - (let ((u (get-account username))) - (and u - (eq (sxhash pass) (account-pass u))))) - -(defun change-passwd! (username newpass) - (let ((u (get-account username))) - (when (not u) - (error "I could not find account ~a." username)) - (setf (account-pass u) (sxhash newpass)) - (write-accounts!))) - -(defun notify-group-created (g) - (post-notification - :subject (fmt "new group ~a by ~a" g (client-username *client*)) - :body (fmt "Blame ~a for the group ~a just created." (client-username *client*) g))) - -(defun notify-user-created (u) - (post-notification - :subject (fmt "new account ~a by ~a" u (client-username *client*)) - :body (fmt "Blame ~a for inviting ~a." (client-username *client*) u))) - -(defun notify-user-unlocked (u) - (let ((guilty (client-username *client*))) - (post-notification - :subject (fmt "account ~a unlocked by ~a" u guilty) - :body (fmt "Blame ~a for unlocking ~a." guilty u)))) - -(defun post-notification (&key subject body) - (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)))))) - -(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)))) - `(("from" . "Loop") - ("subject" . ,subject) - ("newsgroups" . "local.control.news"))))) - :body (data body))) -(defun cmd-list-users (r) - (with-auth - (prepend-response-with - "List of current users:" - (make-response - :code 200 :request r :multi-line 'yes - :data (str:join (crlf-string) (list-users)))))) - -(defun size-of-longest-username () - (loop for u in *accounts* - 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))))) - -(defun universal-to-human (s) - (format-timestring - nil - (universal-to-timestamp s) - :format +asctime-format+)) - -(defun last-time-seen (username) - (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)) -(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))))) -(defun index-from-fs! () - (loop for path in (in-groups (directory "**/*")) - do (let* ((g (str:trim (first (last (pathname-directory path))))) - (i (str:trim (pathname-name path))) - (m (str:trim (extract-mid (fetch-article g i))))) - (when (> (length m) 0) - (format t "article ~a/~a indexed by ~a~%" g i m) - (insert-index m g i))))) - -(defun remake-index-from-fs () - (remake-index!) - (index-from-fs!)) +;;; -*- mode: LISP; syntax: COMMON-LISP; package: LOOP; -*- +(eval-when (:compile-toplevel :load-toplevel :execute) + (ql:quickload + '(:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon + :filesystem-utils) + :silent t)) + +(clsql:enable-sql-reader-syntax) + +(defpackage #:loop + (:use :common-lisp :local-time) + (:import-from :lisp-unit define-test) + (:import-from :org.shirakumo.filesystem-utils + directory-p list-directories list-files) + (:export :main)) + +(in-package #:loop) + +(defun cli/command () + (clingon:make-command + :name "loop" + :description "An NNTP server for a circle of friends." + :version "0.1" + :authors '("Circling Skies ") + :license "GPL v3" + :options (cli/options) + :handler #'cli/main)) + +(defun cli/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 NNTP server reading from stdout" + :short-name #\s + :long-name "server" + :key :server) + (clingon:make-option + :flag + :description "run a REPL on port 4006" + :short-name #\r + :long-name "repl" + :key :repl) + (clingon:make-option + :flag + :description "turn on debug logging on stderr" + :long-name "logging" + :key :logging))) +(defun cli/list-accounts () + (println (str:join (crlf-string) (list-users)))) + +(defun cli/create-account (username args) + (let ((invited-by (car args))) + (cond ((null invited-by) + (println "Must specify who invites the new account.")) + ((get-account username) + (println "Username account ``~a'' already exists." username)) + ((not (get-account invited-by)) + (println "Invited-by account ``~a'' doesn't exist." invited-by)) + (t + (multiple-value-bind (okay? pass-or-error) (new-account! username invited-by) + (if okay? + (progn (println "Okay, account ``~a'' created with password ``~a''." + username pass-or-error) + (notify-user-created username)) + (println "Sorry, ~a." pass-or-error))))))) + +(defun cli/change-passwd (username args) + (let* ((random-passwd (random-string 6)) + (given-passwd (car args)) + (new-passwd (or given-passwd random-passwd))) + (if (not (get-account change-passwd-account)) + (println "No such account ``~a''." change-passwd-account) + (multiple-value-bind (okay? problem) (change-passwd! change-passwd-account new-passwd) + (if okay? + (println "Okay, account ~a now has password ``~a''." change-passwd-account new-passwd) + (println "Sorry, could not change password: ~a." problem)))))) +(defvar *debug* nil) +(defun cli/main (cmd) + (read-accounts!) + (connect-index! "message-id.db") + (create-index!) + (let ((args (clingon:command-arguments cmd)) + (repl (clingon:getopt cmd :repl)) + (server (clingon:getopt cmd :server)) + (ca (clingon:getopt cmd :create-account)) + (change-passwd-account (clingon:getopt cmd :change-passwd)) + (list-accounts (clingon:getopt cmd :list-accounts)) + (logging (clingon:getopt cmd :logging))) + (setf *debug* logging) + (when list-accounts + (cli/list-accounts)) + (when ca + (cli/create-account ca args)) + (when change-passwd-account + (cli/change-passwd change-passwd-account args)) + (when repl + (stderr "Running a REPL on localhost:4006...~%")) + (when server + (server-start)))) +(defun remove-inactive-users! () + (loop for u in *accounts* do + (let ((username (account-username u))) + (format t "Username: ~a~%" username) + (cond ((and (not (locked? username)) + (inactive-from-never-logged-in? username)) + (post-notification + :subject (fmt "account ~a removed by Loop" username) + :body (fmt "~a didn't log in a first time (for ~a month~a) since account creation." + username *months-never-logged-in* + (plural *months-never-logged-in* "s"))) + (remove-account! username) + (format t "Removed ~a due to never logging in.~%" username)) + ((and (not (locked? username)) + (inactive-from-last-seen? username)) + (post-notification + :subject (fmt "account ~a locked by Loop" username) + :body (fmt "~a disappeared for over ~a month~a." + username *months-inactive-allowed* + (plural *months-inactive-allowed* "s"))) + (lock-account! username + (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) + (delete username (account-friends u) :test #'equal))) + (setf *accounts* + (delete-if #'(lambda (a) (equal (account-username a) username)) + *accounts*))) + +(defun lock-account! (username why) + (let ((u (get-account username))) + (setf (account-pass-locked u) (account-pass u)) + (setf (account-pass u) "locked") + (setf (account-pass-locked-why u) why))) +(defparameter *months-inactive-allowed* 3) +(defparameter *months-never-logged-in* 1) + +(defun user-inactive? (username) + (or (inactive-from-never-logged-in? username) + (inactive-from-last-seen? username))) + +(defun inactive-from-never-logged-in? (username) + (let ((u (get-account username))) + (if (ever-logged-in? username) + NIL + (inactive-from? username *months-never-logged-in* + #'(lambda () (account-creation u)))))) + +(defun locked? (username) + (equal "locked" (account-pass (get-account username)))) + +(defun inactive-from-last-post? (username) + (let ((last-post (account-last-post (get-account username))) + (creation (account-creation (get-account username)))) + (inactive-from? username *months-inactive-allowed* + (if last-post + #'(lambda () last-post) + #'(lambda () creation))))) + +(defun inactive-from-last-seen? (username) + (let* ((u (get-account username)) + (last-seen (account-seen u)) + (creation (account-creation u))) + (inactive-from? username *months-inactive-allowed* + (if last-seen + #'(lambda () last-seen) + #'(lambda () creation))))) + +(defun inactive-from? (username months timestamp-source) + (timestamp< + (timestamp+ + (universal-to-timestamp + (funcall timestamp-source)) months :month) + (now))) + +(defun ever-logged-in? (username) + (account-seen (get-account username))) + +(defun never-logged-in? (username) + (not (ever-logged-in? username))) + +(defun list-inactive-users () + (loop for u in *accounts* do + (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)) + +(defun migrate-add-creation-and-post-date! () + (read-accounts!) + (loop for u in *accounts* + do (if (not (account-creation u)) + (setf (account-creation u) (timestamp-to-universal (loop-epoch))) + (setf (account-last-post u) (account-seen u)))) + (write-accounts!)) +(defvar *default-database* nil) +(defun connect-index! (filename) + (setq *default-database* (clsql:connect (list filename) :database-type :sqlite3))) + +(defun create-index! () + (clsql:execute-command "create table if not exists indices + (id varchar(1000), grp varchar(1000), article varchar(300))") + (clsql:execute-command "create unique index if not exists idx_id_1 + on indices (id)")) + +(defun drop-create-index! () + (clsql:execute-command "drop table if exists indices") + (create-index!)) +(defun 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))) + +(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 plural (v suffix) + (if (> v 1) "s" "")) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun fmt (cstr &rest args) + (apply #'format nil (list* cstr args)))) + +(defun out (stream &rest args) + (apply #'format (cons stream args))) + +(defun stderr (&rest args) + (when *debug* + (apply #'out (cons *error-output* args)))) + +(defun stdout (&rest args) + (apply #'out (list* *standard-output* args))) + +(defun println (&rest args) + (apply #'out (list* *standard-output* (str:concat (car args) "~%") (cdr args)))) + +(defun enumerate (ls &optional (first-index 0)) + (loop for e in ls and i from first-index + collect (cons i e))) + +(defun ucs-2->ascii (bs) + ;; I'm a Windows user. + #-win32 bs #+win32 (remove-if #'zerop bs)) + +(defun bad-input (r msg &key code) + (make-response :code (or code 400) :data msg :request r)) + +(defun integer->string (n) + (format nil "~a" n)) + +(defun mkstr (&rest args) ;; a utility + (with-output-to-string (s) + (dolist (a args) (princ a s)))) + +(defun data (&rest args) ;; a utility + (flatten (map 'list #'data->bytes args))) + +(defun crlf () + (vector 13 10)) + +(defun crlf-string () + (format nil "~c~c" #\return #\linefeed)) + +(defun flatten (obj) + (do* ((result (list obj)) + (node result)) + ((null node) (delete nil result)) + (cond ((consp (car node)) + (when (cdar node) (push (cdar node) (cdr node))) + (setf (car node) (caar node))) + (t (setf node (cdr node)))))) + +(defmacro mac (&rest body) + `(macroexpand-1 ,@body)) +(defmacro in-dir (dir &rest body) + `(let ((*default-pathname-defaults* (truename ,dir))) + (uiop:with-current-directory (,dir) + ,@body))) + +(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))) + +(defmacro with-group (g r &rest body) + (let ((g-var (gensym)) + (r-var (gensym))) + `(let ((,g-var ,g) + (,r-var ,r)) + (if (not (group? ,g-var)) + (make-response :code 411 :request ,r-var + :data (format nil "no such group ``~a''" ,g-var)) + (progn ,@body))))) + +(defmacro with-n-args (n r &rest body) + (let ((args-var (gensym)) + (message-var (gensym)) + (n-var n)) + `(let ((,args-var (request-args r)) + (,message-var ,(fmt "bad arguments: needs exactly ~a" n-var))) + (if (not (= ,n-var (length ,args-var))) + (make-response :code 400 :request ,r :data ,message-var) + (progn ,@body))))) + +(defmacro with-group-set (&rest body) + (let ((g-var (gensym))) + `(let ((,g-var (client-group *client*))) + (if (not ,g-var) + (bad-input r "must say GROUP first") + ,@body)))) + +(defmacro with-auth (&rest body) + `(if (not (auth?)) + (make-response :code 400 :data "You must authenticate first.") + (progn ,@body))) + +(defstruct client group (article 1) (username "ANONYMOUS") (auth? 'no)) +(defparameter *client* (make-client)) +(defstruct command fn verb description) +(defparameter *commands-assoc* nil) + +(defun table-of-commands () + `(("GROUP" ,#'cmd-group "sets the current group") + ("NEXT" ,#'cmd-next "increments the article pointer") + ("HELP" ,#'cmd-help "displays this menu") + ("LIST" ,#'cmd-list "lists all groups") + ("AUTHINFO" ,#'cmd-authinfo "makes me trust you") + ("LOGIN" ,#'cmd-login "shorter interface to AUTHINFO") + ("HEAD" ,#'cmd-head "fetches article headers") + ("MODE" ,#'cmd-mode "handles the mode request from clients") + ("BODY" ,#'cmd-body "fetches an article body") + ("POST" ,#'cmd-post "posts your article") + ("ARTICLE" ,#'cmd-article "fetches full articles") + ("XOVER" ,#'cmd-xover "fetches the overview database of a group") + ("CREATE-GROUP" ,#'cmd-create-group + "creates a new group so you can discuss your favorite topic") + ("CREATE-ACCOUNT",#'cmd-create-account + "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") + ("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"))) + +(defun set-up-tables! () + (labels ((build-commands-assoc (ls) + (if (null ls) + nil + (cons (apply #'make-command-pair (car ls)) + (build-commands-assoc (cdr ls))))) + (make-command-pair (name fn desc) + (cons name (make-command :fn fn :verb name :description desc)))) + (setf *commands-assoc* + (sort + (build-commands-assoc (table-of-commands)) + #'string-lessp :key #'car)))) + +(defun get-command (key) + (let ((cmd (assoc key *commands-assoc* :test #'string=))) + (labels ((unrecognized-command () + (make-command :fn #'(lambda (r) + (make-response :code 400 + :data "unrecognized command" + :request r)) + :verb 'unrecognized + :description "a command for all commands typed wrong"))) + (or (cdr cmd) (unrecognized-command))))) +(defstruct request verb args said) +(defstruct response code data request multi-line) + +(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) + (append-crlf-if-needed (string->bytes seq))) + ((listp seq) + (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)))))) + +(defun send-response! (r) + (let ((bs (data (integer->string (response-code r)) " " + (append-crlf-if-needed (response-data r))))) + (my-write bs *standard-output*) + (stderr ">>> ~a" (bytes->string (ucs-2->ascii bs)))) + (when (response-multi-line r) + (let ((bs (data "." (crlf)))) + (my-write bs *standard-output*) + (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))) + ;; What are we going to do with a null request? + (cond ((null ls) (make-request :said (request-said r))) + (t (let ((verb (car ls)) + (args (cdr ls))) + (make-request :said (request-said r) + :verb (str:upcase verb) + :args args)))))) +(defun main-loop () + (let* ((bs (nntp-read-line)) + (ln (bytes->string (ucs-2->ascii bs)))) + (if ln + (let ((r (send-response! (dispatch-line ln)))) + (when (not (response-quit? r)) + (main-loop))) + (progn + (stderr "eof~%") + 'eof)))) + +(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 () + (set-up-tables!) + (send-banner!) + (main-loop)) + +(defun main () + (let ((app (cli/command))) + (clingon:run app))) + +(defun send-banner! () + (send-response! + (make-response :code 200 :data "Welcome! Say ``help'' for a menu."))) +(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))) + +(defun split-vector-helper (delim v len acc limit so-far start) + (if (zerop len) + acc + (let ((pos (search delim v :start2 start :end2 len))) + (cond ((or (not pos) (and limit (= so-far limit))) + (nreverse (cons (subseq v start len) acc))) + (t (split-vector-helper + delim + v + len + (cons (subseq v start (or pos len)) acc) + limit + (1+ so-far) + (+ pos (length delim)))))))) +(defstruct article headers body) + +(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 hs-space-collapsed (hs) + (cl-ppcre:regex-replace-all (format nil "~a[ ~a]+" (crlf-string) #\tab) hs " ")) + +(defun hs-lines (lines) (str:split (crlf-string) lines)) + +(defun parse-header (header) + (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)))) + (when (<= (length h) (+ 2 pos)) + (throw 'article-syntax-error + (values nil (format nil "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) + (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))))) + +(defun get-header (key hs) + (let ((pair (assoc key hs :test #'string=))) + (if pair (cdr pair) ""))) + +(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)))) + (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)))))) + +(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)))) + +(defun read-file-raw (path) + (with-open-file + (in path + :element-type '(unsigned-byte 8) + :if-does-not-exist nil) + (when in + (let* ((size (sb-posix:stat-size (sb-posix:stat path))) + (a (make-array size))) + (read-sequence a in) + a)))) + +(defun fetch-body (g i) + (article-body (parse-article (fetch-article g i)))) +(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) + (empty-response) + (funcall (command-fn (get-command verb)) r)))) + +(defun dispatch-line (ln) + (dispatch (parse-request (make-request :said ln)))) +(defun cmd-authinfo (r) + (let* ((args (mapcar #'str:upcase (request-args r)))) + (cond + ((not (= (length args) 2)) + (bad-input r "No, no: I take exactly two arguments.")) + (t + (multiple-value-bind (cmd arg) (apply #'values args) + (cond + ((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))) + ((string= cmd "PASS") + (if (authinfo-check (client-username *client*) arg) + (progn + (log-user-in!) + (make-response + :code 281 :request r + :data (fmt "Welcome, ~a." (client-username *client*)))) + (make-response :code 400 :request r :data "Sorry. Wrong password."))) + (t (make-response :code 400 :request r :data "Syntax error. Say ``authinfo USER /your-name/'' then ``authinfo PASS /your-pass/''.")))))))) + +(defun authinfo-check (username passwd) + (pass? username passwd)) + +(defun auth? () + (eq 'yes (client-auth? *client*))) + +(defun log-user-in! () + (setf (client-auth? *client*) 'yes) + (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 + (let ((args (request-args r))) + (cond ((null args) + (funcall fn-name r (client-group *client*) (client-article *client*))) + ((= 1 (length args)) + (let* ((n-or-mid (car args))) + (cond ((string-integer? n-or-mid) + (funcall fn-name r (client-group *client*) n-or-mid)) + (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)))))))) + (t (bad-input r "No, no: it takes at most two arguments."))))))) + +(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))) + (cond ((null a) + (make-response + :code 400 :request r + :data (format nil "article ~a/~a does not exist" g i))) + (t + (prepend-response-with + (format nil "~a ~a" i (extract-mid a)) + (make-response :multi-line 'yes :code code + :request r :data (funcall get-data a)))))) + (sb-posix:syscall-error (c) + (make-response + :code 400 :request r + :data (format nil "article ~a/~a: ~a" g i c))))) +(defun cmd-next (r) + (with-auth + (let ((g (client-group *client*)) + (n-cur (client-article *client*))) + (cond + ((not g) (bad-input :code 412 r "must say GROUP first")) + (t (multiple-value-bind (low high len) (group-high-low g) + (declare (ignore low len)) + (cond ((= n-cur high) (bad-input r "you are at the last article already")) + (t (article-next! r g))))))))) + +(defun article-next! (r g) + (setf (client-article *client*) (1+ (client-article *client*))) + (let ((cur (client-article *client*))) + (make-response :code 223 + :request r + :data (format nil "~a ~a" cur (mid-by-name g cur))))) + +(defun mid-by-name (g name) + (extract-mid (fetch-article g name))) +(defun cmd-xover (r) + (with-auth + (with-group-set + (let ((args (request-args r))) + (cond ((null args) + (xover r (client-article *client*) (client-article *client*))) + ((= 1 (length args)) + (multiple-value-bind (s v) + (cl-ppcre:scan-to-strings "([0-9]+)([-]?)([0-9]*)" (car args)) + (cond + ((not s) (make-response :code 502 :request r :data "bad syntax")) + (t (let ((fr (parse-integer (aref v 0))) + (hifen (aref v 1)) + (to (ignore-errors (parse-integer (aref v 2))))) + (when (not (string= hifen "-")) + (setq to fr)) + (xover r fr to)))))) + (t (make-response :code 502 :request r :data "bad syntax"))))))) + +(defun xover (r from to) + (assert (client-group *client*)) + (let* ((g (client-group *client*)) + (ls (get-articles g from to))) + (cond ((= 0 (length ls)) + (make-response :code 420 :request r :data "no articles in the range")) + (t + (prepend-response-with + "Okay, your overview follows..." + (make-response + :code 224 :request r :multi-line 'yes + :data (str:join + (crlf-string) + (loop for i in ls + collect (xover-format-line + i + (remove-if-not + #'(lambda (h) + (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 + (let ((g (car (request-args r)))) + (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))) + (setf (client-article *client*) low) + (make-response :code 211 :request r :data ln)))))))) + +(defun group? (g) + (in-groups + (directory-p g))) + +(defun xgroup? (g) + (directory-p g)) + +(defun set-group! (g) + (setf (client-group *client*) g)) +(defstruct group name high low) + +(defun cmd-list (r) + (prepend-response-with + "Get in the loop! Lots to choose from." + (make-response :code 215 :multi-line 'yes + :data (str:join (crlf-string) (build-groups-lines (build-groups-structs))) + :request r))) + +(defun build-groups-lines (ls) + (reverse + (mapcar + #'(lambda (g) + (format nil "~a ~a ~a y" (group-name g) (group-high g) (group-low g))) + ls))) + +(defun build-groups-structs () + (let ((ret-ls nil)) + (dolist (g (list-groups) ret-ls) + (multiple-value-bind (low high len) (group-high-low g) + (declare (ignore len)) + (setf ret-ls (cons (make-group :name g :high high :low low) ret-ls)))))) + +(defun between? (x from to) + (<= from x to)) +(declaim (inline between?)) + +(defun filesize (path) + (sb-posix:stat-size + (sb-posix:stat path))) + +(defun zero-file? (path) + (= (filesize path) 0)) + +(defun temporary-article? (path) + (or (zero-file? path) + (cl-ppcre:scan "\.tmp$" (namestring path)))) + +(defun article-ready? (path) + (not (temporary-article? path))) + +(defun loop-directory* (directory &rest args &key &allow-other-keys) + #+allegro (apply #'directory directory :directories-are-files NIL :follow-symbolic-links NIL args) + #+(or clozure digitool) (apply #'directory directory :follow-links NIL args) + #+clisp (apply #'directory directory :circle T :if-does-not-exist :ignore args) + #+(or cmucl scl) (apply #'directory directory :follow-links NIL :truenamep NIL args) + #+lispworks (apply #'directory directory :link-transparency NIL args) + #+sbcl (apply #'directory directory :resolve-symlinks NIL args) + #-(or allegro clozure digitool clisp cmucl scl lispworks sbcl) + (apply #'directory directory args)) + +(defun loop-list-files (directory) + (let ((directory (pathname-utils:to-directory directory))) + (let* ((directory (pathname-utils:pathname* directory)) + (entries + (ignore-errors + (loop-directory* + (merge-pathnames pathname-utils:*wild-file* directory))))) + (remove-if #'directory-p entries)))) + +(defun loop-list-directories (directory) + (let ((directory (pathname-utils:to-directory directory))) + (let* (#-(or abcl cormanlisp genera xcl) + (wild (merge-pathnames + #-(or abcl allegro cmucl lispworks sbcl scl xcl) + pathname-utils:*wild-directory* + #+(or abcl allegro cmucl lispworks sbcl scl xcl) "*.*" + directory)) + (dirs + #+(or abcl xcl) (system:list-directory directory) + #+cormanlisp (cl::directory-subdirs directory) + #+genera (handler-case (loop for (p . k) in (fs:directory-list directory) + when (eql :directory k) collect p) + (fs:directory-not-found () nil)) + #+clozure (ignore-errors (directory* wild :directories T :files NIL)) + #+mcl (ignore-errors (directory* wild :directories T)) + #-(or abcl xcl cormanlisp genera clozure mcl) (loop-directory* wild))) + (loop for path in dirs + when (directory-p path) + collect (pathname-utils:force-directory path))))) + +(defun get-articles (g &optional from to) + (in-groups ;; We might want to optimize this some day. That's a + ;; problem to be studied. + (let ((as (articles->integers + (remove-if #'temporary-article? (loop-list-files (truename g)))))) + (sort (remove-if-not + #'(lambda (x) (between? x (or from x) (or to x))) + as) + #'<)))) + +(defun group-high-low (g) + (let* ((articles (get-articles g)) + (sorted-ints (sort articles #'<))) + (values (or (car sorted-ints) 0) + (or (car (last sorted-ints)) 0) + (length sorted-ints)))) + +(defun articles->integers (ls) + (remove-if #'null + (mapcar #'(lambda (g) + (ignore-errors + (parse-integer (basename (uiop:unix-namestring g))))) + ls))) + +(defun list-groups () + (let ((groups (in-groups (loop-list-directories (truename "."))))) + (sort (mapcar #'(lambda (g) (basename (uiop:unix-namestring g))) groups) + #'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 + "What's on the menu today?" + (make-response :code 200 :multi-line 'yes + :request r + :data (str:join (crlf-string) lines))))) +(defun menu (ls) + (if (null ls) + nil + (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))))) + (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 text/plain? (header-s) + ;; I say T when S begins with "text/plain" or when S is "". + (let* ((s (str:collapse-whitespaces header-s)) + (needle "text/plain") + (len (min (length needle) (length s)))) + (or (zerop len) + (and (<= (length needle) (length s)) + (string= needle s :end1 len :end2 len))))) + +(defun headers-required-from-clients () + '("from" "newsgroups" "subject")) +(defun suggest-message-id (&optional (n 20)) + (format nil "<~a@loop>" (random-string n))) + +(defun random-string (size) + (let* ((universe "abcdefghijklmnopqrstuvwxyz") + (len (length universe)) + (state (make-random-state t)) + mid) + (dotimes (c size) + (setq mid (cons (char universe (random len state)) mid))) + (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))) +(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 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)) +(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 + :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?) + (make-response :code 400 :request r + :data (format nil "Sorry. Your article doesn't conform: ~a." error)) + (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) + (dolist (ng ngs) + (if (and (group-name-conforms? ng) + (group? ng)) + (progn + (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))) + (if (zerop (- (length ngs) (length ngs-dont-exist))) + (values 400 "Sorry. There was not a single valid newsgroup specified.") + (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."))))))) +(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))) + +(defun save-article-try (name-try bs) + (let ((name (format nil "~a" name-try)) + (tmp (format nil "~a.tmp" name-try))) + (with-open-file + (s name + :direction :output + :if-exists nil ;; an atomic operation + :if-does-not-exist :create) + (when (null s) + (progn + (stderr "warning: save-article-try: ~a exists~%" name) + (return-from save-article-try 'name-exists)))) + (with-open-file + (s tmp + :direction :output + :if-exists :error + :if-does-not-exist :create + :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) + (when (not (eql 'name-exists (save-article-try name a))) + (return (values name (insert-index message-id g (fmt "~a" name)))))))) + +(defun get-next-article-id (g) + (multiple-value-bind (low high len) (group-high-low g) + (declare (ignore low len)) + (1+ high))) +(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))) + (cond ((or (null x) (= x 10)) + (let ((bs (and acc (nreverse (if (= (car acc) 13) (cdr acc) acc))))) + (stderr "<<< ~a~%" (bytes->string (ucs-2->ascii bs))) + bs)) + (t (nntp-read-line s (cons x acc)))))) + +(defun list->bytes (ls) + (mapcar #'data->bytes ls)) + +(defun vector->bytes (v) + (mapcar #'data->bytes (coerce v 'list))) + +(defun data->bytes (d) + (cond ((null d) nil) + ((integerp d) (list d)) + ((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)))))) + +(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)) + +(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))))) + (multiple-value-bind (okay? reason) + (group-name-conforms? g) + (if (not okay?) + (make-response :code 580 :request r + :data (format nil "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" + (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))))))))))) + +(defun group-name-conforms? (g) + (let ((okay? (cl-ppcre:scan-to-strings "^([a-z0-9]+)" g))) + (if okay? + (values t nil) + (values nil "must match ^([a-z0-9]+)")))) +(defun cmd-create-account (r) + (with-auth + (with-n-args 1 r + (let* ((args (mapcar #'str:upcase (request-args r))) + (username (car args))) + (multiple-value-bind (username pass-or-error) (new-account! username (client-username *client*)) + (if (not username) + (make-response :code 400 :request r + :data (fmt "~a. Choose a new name." pass-or-error)) + (progn + (notify-user-created username) + (make-response :code 200 :request r + :data (fmt "Okay, account ~a created with password ``~a''." + username pass-or-error))))))))) + +(defparameter *accounts* nil) +(defstruct account username seen last-post friends pass pass-locked pass-locked-why creation) + +(defun read-accounts! () + (let ((*package* (find-package '#:loop))) + (with-open-file + (s "accounts.lisp" + :direction :input) + (setq *accounts* (read s)))) + *accounts*) + +(defun new-account! (username invited-by) + (let* ((u (str:upcase username)) + (p (random-string 6)) + (a (make-account :username u + :pass (sxhash (str:upcase p)) + :creation (get-universal-time)))) + (if (get-account u) + (values nil (fmt "account ~a already exists" u)) + (progn + (push u (account-friends (get-account invited-by))) + (push a *accounts*) + (write-accounts!) + (values (str:upcase username) p))))) +(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))))) + +(defun get-account (username) + (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 + (let* ((args (mapcar #'str:upcase (request-args r))) + (username (car args))) + (cond ((not (get-account username)) + (make-response :code 400 :request r + :data "No such account ~a." username)) + ((not (locked? username)) + (make-response :code 400 :request r + :data (fmt "Can't unlock ~a because it's not locked." username))) + (t + (unlock-account! username) + (notify-user-unlocked username) + (make-response :code 200 :request r + :data (fmt "Okay, account ~a unlocked." username)))))))) + +(defun unlock-account! (username) + (let ((u (get-account username))) + (cond ((not u) + (values nil "no such account")) + ((not (locked? username)) + (values nil "account isn't locked")) + (t + (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 + ((not (= (length args) 2)) + (bad-input r "Usage: login your-username your-password")) + (t + (multiple-value-bind (name pass) (apply #'values args) + (cond + ((pass? name pass) + (log-user-in-as! name) + (make-response :code 200 :request r + :data (fmt "Welcome, ~a." name))) + (t (make-response :code 400 :request r + :data (fmt "Wrong password."))))))))) + +(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)))) + (cond + ((not (= (length args) 2)) + (bad-input r "Usage: passwd current-password new-password")) + (t + (multiple-value-bind (cur new) (apply #'values args) + (cond + ((pass? (client-username *client*) cur) + (multiple-value-bind (okay? problem) (change-passwd! (client-username *client*) new) + (if okay? + (make-response :code 200 :request r + :data "You got it. Password changed.") + (make-response :code 500 :request r + :data (fmt "Sorry: ~a" problem))))) + (t (make-response :code 400 :request r + :data (fmt "Sorry. Wrong password.")))))))))) + +(defun pass? (username pass) + (let ((u (get-account username))) + (and u + (eq (sxhash pass) (account-pass u))))) + +(defun change-passwd! (username newpass) + (let ((u (get-account username))) + (when (not u) + (error "I could not find account ~a." username)) + (setf (account-pass u) (sxhash newpass)) + (write-accounts!))) + +(defun notify-group-created (g) + (post-notification + :subject (fmt "new group ~a by ~a" g (client-username *client*)) + :body (fmt "Blame ~a for the group ~a just created." (client-username *client*) g))) + +(defun notify-user-created (u) + (post-notification + :subject (fmt "new account ~a by ~a" u (client-username *client*)) + :body (fmt "Blame ~a for inviting ~a." (client-username *client*) u))) + +(defun notify-user-unlocked (u) + (let ((guilty (client-username *client*))) + (post-notification + :subject (fmt "account ~a unlocked by ~a" u guilty) + :body (fmt "Blame ~a for unlocking ~a." guilty u)))) + +(defun post-notification (&key subject body) + (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)))))) + +(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)))) + `(("from" . "Loop") + ("subject" . ,subject) + ("newsgroups" . "local.control.news"))))) + :body (data body))) +(defun cmd-list-users (r) + (with-auth + (prepend-response-with + "List of current users:" + (make-response + :code 200 :request r :multi-line 'yes + :data (str:join (crlf-string) (list-users)))))) + +(defun size-of-longest-username () + (loop for u in *accounts* + 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))))) + +(defun universal-to-human (s) + (format-timestring + nil + (universal-to-timestamp s) + :format +asctime-format+)) + +(defun last-time-seen (username) + (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)) +(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))))) +(defun index-from-fs! () + (loop for path in (in-groups (directory "**/*")) + do (let* ((g (str:trim (first (last (pathname-directory path))))) + (i (str:trim (pathname-name path))) + (m (str:trim (extract-mid (fetch-article g i))))) + (when (> (length m) 0) + (format t "article ~a/~a indexed by ~a~%" g i m) + (insert-index m g i))))) + +(defun remake-index-from-fs () + (drop-create-index!) + (index-from-fs!)) diff --git a/loop.nw b/loop.nw index 00f8d2a..91cba24 100644 --- a/loop.nw +++ b/loop.nw @@ -7,7 +7,7 @@ \usepackage[T1]{fontenc} \usepackage[utf8]{inputenc} \usepackage{csquotes} -\usepackage[brazil]{babel} +\usepackage{babel} \usepackage{etoolbox} \AtBeginEnvironment{quote}{\small} @@ -16,14 +16,14 @@ %% \usepackage[backend=biber]{biblatex} %% \addbibresource{refs.bib} %% \renewcommand{\cite}{\parencite} -\usepackage[hyperref]{xcolor} +% \usepackage[hyperref]{xcolor} \usepackage[colorlinks=true,citecolor=]{hyperref} % linkcolor=red \usepackage{amsmath,amsthm,amssymb} \allowdisplaybreaks \usepackage{lmodern} \usepackage{noweb} -\noweboptions{brazil,longchunks,smallcode} +\noweboptions{longchunks,smallcode} \DeclareMathOperator{\mdc}{mdc} \DeclareMathOperator{\gcdext}{gcdext} \DeclareMathOperator{\remainder}{remainder} @@ -85,25 +85,30 @@ way, the conference takes place. But \lp\ has nothing to do with e-mail. \Lp\ uses a communication strategy---called a ``protocol''---that is even older than the web itself. The web started out around 1989--1990 and the protocol -\lp\ uses was conceived in 1979 and implemented in 1980. The name of -the protocol used by \lp\ is NNTP---Network News Transfer Protocol. -Since e-mail was already daily practice of members of the Internet -back then, many things from e-mail were taken by the NNTP designers. -So, an NNTP message looks a lot like an e-mail message and the -two---NNTP and SMTP (the protocol used by e-mail)---can often mingle -seamlessly. The impression we get from using NNTP is that we're -sending e-mail to a certain group of people. It's as though the -message goes into a collective mailbox and anyone interested in that -mailbox reads the messages there. If anyone would like to reply to a -message, they do so and, this way, communication flows among the -interested crowd. If anyone would like to leave the group, nothing is -needed---the person just doesn't go back to read any more messages. -Unlike mailing lists, there is no need to formally 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''. +\lp\ uses begins its history in 1979, the year in which AT\&T released +UNIX V7, which was UUCP-ready. The name UUCP stands for [U]NIX to +[U]NIX [c]o[p]y. It's both a protocol and a set of programs for +copying files between UNIX systems. People begun exchanging messages +by copying files between machines. The idea eventually evolved into a +protocol called NNTP---Network News Transfer Protocol---, which is the +protocol used by \lp. (The protocol used to be called NetNews +Transfer Protocol.) Since e-mail was already daily practice of +members of the Internet back then, many things from e-mail were taken +by the NNTP designers. So, an NNTP message looks a lot like an e-mail +message and the two---NNTP and SMTP (the protocol used by +e-mail)---can often mingle seamlessly. The impression we get from +using NNTP is that we're sending e-mail to a certain group of people. +It's as though the message goes into a collective mailbox and anyone +interested in that mailbox reads the messages there. If anyone would +like to reply to a message, they do so and, this way, communication +flows among the interested crowd. If anyone would like to leave the +group, nothing is needed---the person just doesn't go back to read any +more messages. Unlike mailing lists, there is no need to formally +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''. 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 @@ -255,19 +260,19 @@ the response. You can get a string version of these numbers: \begin{verbatim} LOOP> (bytes->string (response-data (dispatch (make-request :verb "HELP")))) -"What's on the menu today? -ARTICLE fetches full articles -AUTHINFO makes me trust you -BODY fetches an article body -GROUP sets the current group -HEAD fetches article headers -HELP displays this menu -LIST lists all groups -MODE handles the mode request from clients -NEXT increments the article pointer -POST posts your article -QUIT politely says good-bye -XDD displays your state of affairs +"What's on the menu today? +ARTICLE fetches full articles +AUTHINFO makes me trust you +BODY fetches an article body +GROUP sets the current group +HEAD fetches article headers +HELP displays this menu +LIST lists all groups +MODE handles the mode request from clients +NEXT increments the article pointer +POST posts your article +QUIT politely says good-bye +XDD displays your state of affairs XOVER fetches the overview database of a group" \end{verbatim} @@ -359,6 +364,18 @@ way, they work together. And \lp\ handles only a text stream, which is why it's so easy to connect a keyboard to it and interact with it through the command line as illustrated in Section~\ref{sec:design}. +\section{The description of the package} + +<>= +An NNTP server for a circle of friends. +@ + +<>= +0.1 +@ + +These chunks are used in [[loop.asd]]. + \section{The representation of a client} How do we represent a client? A client is typically reading a group @@ -557,19 +574,143 @@ itself---so we can cascade actions based on a user's request. (defun request-quit? (r) (and r (string= 'quit (request-verb r)))) (defun response-quit? (r) (and r (request-quit? (response-request r)))) -(defun main () - (send-banner!) +(defun server-start () (set-up-tables!) - (read-accounts!) - (connect-index! "message-id.db") - (create-index!) + (send-banner!) (main-loop)) +(defun main () + (let ((app (cli/command))) + (clingon:run app))) + (defun send-banner! () (send-response! (make-response :code 200 :data "Welcome! Say ``help'' for a menu."))) @ %def main main-loop +\section{Command-line parsing} + +We're using the clingon library as per Vincent Dardel suggestion in +``The Common Lisp Cookbook''. (Thanks, Vincent!) We begin with +writing a description of the program and options it understands. XXX: +notice I don't know how to support a two-argument option, so I hacked +a solution away. + +<>= +(defun cli/command () + (clingon:make-command + :name "loop" + :description "<>" + :version "<>" + :authors '("Circling Skies ") + :license "GPL v3" + :options (cli/options) + :handler #'cli/main)) + +(defun cli/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 NNTP server reading from stdout" + :short-name #\s + :long-name "server" + :key :server) + (clingon:make-option + :flag + :description "run a REPL on port 4006" + :short-name #\r + :long-name "repl" + :key :repl) + (clingon:make-option + :flag + :description "turn on debug logging on stderr" + :long-name "logging" + :key :logging))) +@ + +The command-line options form a language. The user specifies +everything he wants with flags. If he wants nothing, for instance, he +specifies nothing and then nothing happens. XXX: I'd like to have a +default action (which would be running the server) that is invoked by +default if none of the other options would run. But I don't know how +to do that yet. + +<>= +(defun cli/list-accounts () + (println (str:join (crlf-string) (list-users)))) + +(defun cli/create-account (username args) + (let ((invited-by (car args))) + (cond ((null invited-by) + (println "Must specify who invites the new account.")) + ((get-account username) + (println "Username account ``~a'' already exists." username)) + ((not (get-account invited-by)) + (println "Invited-by account ``~a'' doesn't exist." invited-by)) + (t + (multiple-value-bind (okay? pass-or-error) (new-account! username invited-by) + (if okay? + (progn (println "Okay, account ``~a'' created with password ``~a''." + username pass-or-error) + (notify-user-created username)) + (println "Sorry, ~a." pass-or-error))))))) + +(defun cli/change-passwd (username args) + (let* ((random-passwd (random-string 6)) + (given-passwd (car args)) + (new-passwd (or given-passwd random-passwd))) + (if (not (get-account change-passwd-account)) + (println "No such account ``~a''." change-passwd-account) + (multiple-value-bind (okay? problem) (change-passwd! change-passwd-account new-passwd) + (if okay? + (println "Okay, account ~a now has password ``~a''." change-passwd-account new-passwd) + (println "Sorry, could not change password: ~a." problem)))))) +@ + +Now let's write the main procedure in command-line parsing. + +<>= +(defvar *debug* nil) +(defun cli/main (cmd) + (read-accounts!) + (connect-index! "message-id.db") + (create-index!) + (let ((args (clingon:command-arguments cmd)) + (repl (clingon:getopt cmd :repl)) + (server (clingon:getopt cmd :server)) + (ca (clingon:getopt cmd :create-account)) + (change-passwd-account (clingon:getopt cmd :change-passwd)) + (list-accounts (clingon:getopt cmd :list-accounts)) + (logging (clingon:getopt cmd :logging))) + (setf *debug* logging) + (when list-accounts + (cli/list-accounts)) + (when ca + (cli/create-account ca args)) + (when change-passwd-account + (cli/change-passwd change-passwd-account args)) + (when repl + (stderr "Running a REPL on localhost:4006...~%")) + (when server + (server-start)))) +@ %def cli/options cli/command + \section{The request dispatching mechanism} Dispatching requests means consuming one and invoking the correct @@ -681,11 +822,15 @@ interpreting such bytes. That's why we call [[read-sequence]] here. (read-file-raw (format nil "~a/~a" g i)))) (defun read-file-raw (path) - (let* ((size (sb-posix:stat-size (sb-posix:stat path))) - (a (make-array size))) - (with-open-file (in path :element-type '(unsigned-byte 8)) - (read-sequence a in) - a))) + (with-open-file + (in path + :element-type '(unsigned-byte 8) + :if-does-not-exist nil) + (when in + (let* ((size (sb-posix:stat-size (sb-posix:stat path))) + (a (make-array size))) + (read-sequence a in) + a)))) (defun fetch-body (g i) (article-body (parse-article (fetch-article g i)))) @@ -728,7 +873,8 @@ Lisp offers me [[labels]], but [[labels]] don't seem so helpful when I'm at the REPL. When I use [[defun]], I'm able to always invoke the procedure at the REPL, but that's not so with [[labels]]. I guess the use of [[labels]] is when the procedure is so trivial that we have no -reason to think we're doing to debug it.} %% TODO +reason to think we're doing to debug it.} XXX: replace menu with +[[loop]]. <>= (defun cmd-help (r) @@ -803,16 +949,10 @@ Syntax error. Say ``authinfo USER /your-name/'' then ``authinfo PASS /your-pass/ \subsection{{\tt CREATE-ACCOUNT}} -We allow authenticated members to invite their friends. - -%% A propósito, estamos removendo a conta {\tt ROOT} de exibição. O que -%% significa que {\tt ROOT} não nem mesmo se conectar ao \Lp. Se -%% desejarmos que {\tt ROOT} se conecte, talvez a gente possa fazer -%% código especialmente pra gerenciar a conta dele. Fazemos assim pra -%% não permitir que usuários tenham qualquer chance de -%% -%% (remove-if #'(lambda (u) (equal "ROOT" (account-username u))) -%% (read s)) +We allow authenticated members to invite their friends. Notice that +we're not doing any kind of checking on the username. XXX: take a +look at how we verify group names match a certain regex and apply the +same check here. <>= (defun cmd-create-account (r) @@ -820,7 +960,7 @@ We allow authenticated members to invite their friends. (with-n-args 1 r (let* ((args (mapcar #'str:upcase (request-args r))) (username (car args))) - (multiple-value-bind (username pass-or-error) (new-account! username) + (multiple-value-bind (username pass-or-error) (new-account! username (client-username *client*)) (if (not username) (make-response :code 400 :request r :data (fmt "~a. Choose a new name." pass-or-error)) @@ -841,7 +981,7 @@ We allow authenticated members to invite their friends. (setq *accounts* (read s)))) *accounts*) -(defun new-account! (username) +(defun new-account! (username invited-by) (let* ((u (str:upcase username)) (p (random-string 6)) (a (make-account :username u @@ -849,12 +989,12 @@ We allow authenticated members to invite their friends. :creation (get-universal-time)))) (if (get-account u) (values nil (fmt "account ~a already exists" u)) - (let ((c (get-account (client-username *client*)))) - (push u (account-friends c)) + (progn + (push u (account-friends (get-account invited-by))) (push a *accounts*) (write-accounts!) (values (str:upcase username) p))))) -@ %def CREATE-ACCOUNT +@ %def CREATE-ACCOUNT new-account! Notice that we have a race condition in [[write-accounts]]. What is the problem? Two processes in parallel may ask for the writing of @@ -1094,12 +1234,13 @@ even cache the overview of the group.) %% TODO (defun article-ready? (path) (not (temporary-article? path))) +<> + (defun get-articles (g &optional from to) - (in-groups ;; We might want to optimize this some day. Most likely, - ;; though, we'll not be using directories. That's a + (in-groups ;; We might want to optimize this some day. That's a ;; problem to be studied. (let ((as (articles->integers - (remove-if #'temporary-article? (cl-fad:list-directory g))))) + (remove-if #'temporary-article? (loop-list-files (truename g)))))) (sort (remove-if-not #'(lambda (x) (between? x (or from x) (or to x))) as) @@ -1120,7 +1261,7 @@ even cache the overview of the group.) %% TODO ls))) (defun list-groups () - (let ((groups (in-groups (cl-fad:list-directory ".")))) + (let ((groups (in-groups (loop-list-directories (truename "."))))) (sort (mapcar #'(lambda (g) (basename (uiop:unix-namestring g))) groups) #'string-lessp))) @@ -1139,6 +1280,61 @@ slash, we invoke [[pathname]]. Otherwise, we invoke {\tt (file-namestring s)))) @ %def get-articles group-high-low +To list directories and files, I have been using +\href{https://github.com/Shinmera/filesystem-utils/tree/master}{{\tt + filesystem-utils}} by Yukari Hafner. I found an issue with both + [[list-directories]] and [[list-files]] in a fresh install of + FreeBSD 14.2 and in a Debian 8.11 codename jessie. The issue is + that the [[#+cffi]] chunk of the source code incorrectly produced + [[NIL]]. (Dramatically, the same was not true in a FreeBSD + 14.1.) The source code had an alternative chunk of code for + [[#-cffi]] and I discovered that this alternative worked on these + systems I tested. So, as a workaround, I incorporate these + procedures below using the chunk [[#-cffi]] to get \Lp\ working + on these systems. + +<>= +(defun loop-directory* (directory &rest args &key &allow-other-keys) + #+allegro (apply #'directory directory :directories-are-files NIL :follow-symbolic-links NIL args) + #+(or clozure digitool) (apply #'directory directory :follow-links NIL args) + #+clisp (apply #'directory directory :circle T :if-does-not-exist :ignore args) + #+(or cmucl scl) (apply #'directory directory :follow-links NIL :truenamep NIL args) + #+lispworks (apply #'directory directory :link-transparency NIL args) + #+sbcl (apply #'directory directory :resolve-symlinks NIL args) + #-(or allegro clozure digitool clisp cmucl scl lispworks sbcl) + (apply #'directory directory args)) + +(defun loop-list-files (directory) + (let ((directory (pathname-utils:to-directory directory))) + (let* ((directory (pathname-utils:pathname* directory)) + (entries + (ignore-errors + (loop-directory* + (merge-pathnames pathname-utils:*wild-file* directory))))) + (remove-if #'directory-p entries)))) + +(defun loop-list-directories (directory) + (let ((directory (pathname-utils:to-directory directory))) + (let* (#-(or abcl cormanlisp genera xcl) + (wild (merge-pathnames + #-(or abcl allegro cmucl lispworks sbcl scl xcl) + pathname-utils:*wild-directory* + #+(or abcl allegro cmucl lispworks sbcl scl xcl) "*.*" + directory)) + (dirs + #+(or abcl xcl) (system:list-directory directory) + #+cormanlisp (cl::directory-subdirs directory) + #+genera (handler-case (loop for (p . k) in (fs:directory-list directory) + when (eql :directory k) collect p) + (fs:directory-not-found () nil)) + #+clozure (ignore-errors (directory* wild :directories T :files NIL)) + #+mcl (ignore-errors (directory* wild :directories T)) + #-(or abcl xcl cormanlisp genera clozure mcl) (loop-directory* wild))) + (loop for path in dirs + when (directory-p path) + collect (pathname-utils:force-directory path))))) +@ %def loop-list-directories loop-list-files + \subsection{{\tt GROUP}}\label{sec:group} We just need to verify if the group exists and modify [[*client*]]. @@ -1157,10 +1353,10 @@ We just need to verify if the group exists and modify [[*client*]]. (defun group? (g) (in-groups - (cl-fad:directory-exists-p g))) + (directory-p g))) (defun xgroup? (g) - (cl-fad:directory-exists-p g)) + (directory-p g)) (defun set-group! (g) (setf (client-group *client*) g)) @@ -1214,27 +1410,39 @@ Section~\ref{sec:index} for the implementation of the index. (typical-cmd-response 222 r g i #'(lambda (a) (encode-body (article-body (parse-article a)))))) @ -When we process such commands, it's typical that we need to verify the -existence of files {\em et cetera}. The procedure that might throw -[[sb-posix:syscall-error]] is [[sb-posix:stat-size]], which we use to -know how many bytes are there in an article, a necessary task in -producing the \verb|OVERVIEW|. +In processing such commands, we need to verify the existence of files +{\em et cetera}. The procedure [[fetch-article]] returns [[nil]] when +the article requested doesn't exist and it throws +[[sb-posix:syscall-error]] due to [[sb-posix:stat-size]], which we +need to find the size of the article. We need to know the file size +not only to allocate an array at the right size, but also because we +must provide the size when producing the \verb|OVERVIEW|. If a +problem such as [[sb-posix:syscall-error]] appears, we just inform the +client and terminate the request---nothing else to do. + +XXX: instead of only catching [[sb-posix:syscall-error]], we should +catch anything else, reporting the error. Otherwise, we will blow up +in case of some unexpected error, which might not be a bad idea---as +long as we can log these errors and get a report later on of what's +going on so we can improve the code. <>= (defun typical-cmd-response (code r g i get-data) - (let ((a (handler-case (fetch-article g i) - (sb-posix:syscall-error (c) - (make-response :code 400 :request r - :data (format nil "article ~a/~a: ~a" g i c))) - (sb-ext:file-does-not-exist (c) - (declare (ignore c)) - (make-response :code 400 :request r - :data (format nil "article ~a/~a does not exist" g i)))))) - (cond ((typep a 'response) a) - (t (prepend-response-with - (format nil "~a ~a" i (extract-mid a)) - (make-response :multi-line 'yes :code code - :request r :data (funcall get-data a))))))) + (handler-case + (let ((a (fetch-article g i))) + (cond ((null a) + (make-response + :code 400 :request r + :data (format nil "article ~a/~a does not exist" g i))) + (t + (prepend-response-with + (format nil "~a ~a" i (extract-mid a)) + (make-response :multi-line 'yes :code code + :request r :data (funcall get-data a)))))) + (sb-posix:syscall-error (c) + (make-response + :code 400 :request r + :data (format nil "article ~a/~a: ~a" g i c))))) @ %def typical-cmd-response The command \verb|NEXT| has a slight different semantics. @@ -1506,10 +1714,17 @@ user to either remove the invalid group of type it up properly. (setf (account-last-post u) (get-universal-time)))) @ %def update-last-post-date! -If [[save-article-try]] returns [[NIL]], then [[probe-file]] -has found an article with name [[name-try]], that is, the procedure -is only successful if [[name-try]] is not yet taken and the writing -takes place successfully. +The job of [[save-article-try]] is to atomically allocate an article +name in a group. The atomicity is achieved with [[:if-exists]] in the +[[with-open-file]] macro. When [[if:-exists]] is used, the {\tt open} +system call uses the flag \verb|O_EXCL|, given us an atomic operation. +So, the first [[with-open-file]] allocates the name. If successful, +we take our time writing the article to the temporary file and we +atomically rename it at the end. We should close [[name]] before +trying to [[rename-no-extention]]---on UNIX systems, renaming an open +target might be okay, but that's not allowed on Windows systems. Even +though we have no interest in running \Lp\ on Windows, closing before +renaming it sounds more like the Right Thing to do. <>= (defun rename-no-extension (old new) @@ -1521,9 +1736,12 @@ takes place successfully. (with-open-file (s name :direction :output - :if-exists :error ;; an atomic operation - :if-does-not-exist :create)) - ;(format t "save-article-try: ~a~%" name) + :if-exists nil ;; an atomic operation + :if-does-not-exist :create) + (when (null s) + (progn + (stderr "warning: save-article-try: ~a exists~%" name) + (return-from save-article-try 'name-exists)))) (with-open-file (s tmp :direction :output @@ -1532,42 +1750,25 @@ takes place successfully. :element-type '(unsigned-byte 8)) (write-sequence bs s)) (rename-no-extension tmp name))) -@ +@ %def save-article-try -The procedure [[save-article-insist]] can return [[NIL]] and still -have perfectly done its job: it's possible for [[insert-index]] to -return [[NIL]] because [[message-id]] may already exist in the index, -but that may be no error---for example, when cross-posting. The -strategy is to write the article using [[name-try]]. If it's not -possible to write it because of a [[sb-ext:file-exists]] condition, -then we try the new name {\tt (1+ name-try)} and we repeat these -attempts until we make it. If other condition appears, we let it -propagate up the stack. If we get to the second [[let]], it's because -the article has been saved successfully, so we finish with whatever it -is that [[insert-index-or-log-failure]] must do. +The procedure [[save-article-insist]] insists on calling +[[save-article-try]] until it finds an article name that has not been +allocated. Notice that the argument [[name]] is an integer, so +[[name]] is incremented at each iteration. <>= (defun save-article-insist (g name a message-id) (loop for name from name do (in-dir (format nil "groups/~a/" g) - (handler-case - (save-article-try name a) - (sb-ext:file-exists () - ;; We might want to log the fact. - ;(format t "name ~a already exists...~%" name) - ) - (:no-error (new before after) ;; the return values from return-file - (declare (ignore new before after)) - (return (values name (insert-index message-id g (fmt "~a" name))))))))) - -(defun get-next-article-name (g) - (format nil "~a" (get-next-article-id g))) + (when (not (eql 'name-exists (save-article-try name a))) + (return (values name (insert-index message-id g (fmt "~a" name)))))))) (defun get-next-article-id (g) (multiple-value-bind (low high len) (group-high-low g) (declare (ignore low len)) (1+ high))) -@ +@ %def save-article-insist get-next-article-id {\bf How to read lines in the NNTP protocol?} We've implemented the most trivial strategy possible. It's also the slowest. What I think @@ -1860,10 +2061,10 @@ specify anything. (clsql:execute-command "create unique index if not exists idx_id_1 on indices (id)")) -(defun remake-index! () +(defun drop-create-index! () (clsql:execute-command "drop table if exists indices") (create-index!)) -@ %def create-index! remake-index! connect-index! +@ %def create-index! drop-create-index! connect-index! Of course, the creation and connection of the index must occur before [[main-loop]], so it takes place in [[main]]. @@ -1986,19 +2187,23 @@ we need to index it. (insert-index m g i))))) (defun remake-index-from-fs () - (remake-index!) + (drop-create-index!) (index-from-fs!)) @ Here's a program to build the index from a UNIX shell. <>= -(load "~/.sbclrc") +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) (ql:quickload :loop :silent t) (in-package #:loop) (connect-index! "message-id.db") -(remake-index!) -(index-from-fs) +(drop-create-index!) +(index-from-fs!) (format t "Index built.~%") @ @@ -2019,21 +2224,25 @@ Index built. \section{Deletion and locking of inactive accounts}\label{sec:inactive-users} -In [[remove-friend]], note that [[username]] is the account name and -[[friend]] is the name of the account being removed. Notice as well -that we only know who invited the person after we can get a hold of -the account in [[accounts.lisp]]. This means we must scan each -account to delete an account---we can't delete an account and still -leave the account as someone's friend. +XXX: remove this paragraph from here; present the program first and +then talk about it. In [[remove-friend]], note that [[username]] is +the account name and [[friend]] is the name of the account being +removed. Notice as well that we only know who invited the person +after we can get a hold of the account in [[accounts.lisp]]. This +means we must scan each account to delete an account---we can't delete +an account and still leave the account as someone's friend. The program [[cron-remove-inactive-users.lisp]] can be executed every day at midnight, say. <>= -(load "~/.sbclrc") +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) (ql:quickload :loop :silent t) (in-package #:loop) -;; (format t *default-pathname-defaults*) (read-accounts!) (connect-index! "message-id.db") (remove-inactive-users!) @@ -2069,22 +2278,33 @@ with [[setf]]. %% TODO (fmt "disappeared for over ~a months" *months-inactive-allowed*)) (format t "Locked ~a due to long-time-no-see.~%" username)))))) +@ %def remove-inactive-users! +To remove an account, we need to first remove the username (to be +removed) from anyone's list of friends. So, this involves scanning +the entire list of accounts. Also, notice that delete ``may modify +{\em sequence}''. More importantly is to understand tha we really +must {\tt setf} the return, otherwise we might find the deletion did +not take effect---for example, when deleting the first element of a +list. (This deserves a better explanation, but if you know how linked +lists are implemented in C, say, then you're likely well aware of how +it works.) + +<>= (defun remove-account! (username) (loop for u in *accounts* do - (delete-if #'(lambda (x) (equal x username)) (account-friends u))) - (delete-if #'(lambda (x) (equal username (account-username x))) *accounts*)) + (setf (account-friends u) + (delete username (account-friends u) :test #'equal))) + (setf *accounts* + (delete-if #'(lambda (a) (equal (account-username a) username)) + *accounts*))) (defun lock-account! (username why) (let ((u (get-account username))) (setf (account-pass-locked u) (account-pass u)) (setf (account-pass u) "locked") (setf (account-pass-locked-why u) why))) - -(defun remove-friend (username friend) - (remove-if #'(lambda (x) (equal x friend)) - (account-friends (get-account username)))) -@ %def remove-account! remove-friend +@ %def remove-account! Accounts that do not have a creation date up until today---Tue Sep 17 21:37:18 ESAST 2024---will have its creation dates migrated to the @@ -2108,7 +2328,11 @@ New system administrators of \Lp\ will never need to run this. Here's a program to run the migration in a UNIX shell. <>= -(load "~/.sbclrc") +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) (ql:quickload :loop :silent t) (in-package #:loop) (migrate-add-creation-and-post-date!) @@ -2240,15 +2464,22 @@ means 2 bytes. So our conversion is just removing the first byte. (defun plural (v suffix) (if (> v 1) "s" "")) -(defun debug? () nil) - (eval-when (:compile-toplevel :load-toplevel :execute) (defun fmt (cstr &rest args) (apply #'format nil (list* cstr args)))) +(defun out (stream &rest args) + (apply #'format (cons stream args))) + (defun stderr (&rest args) - (when (debug?) - (apply #'format (cons *error-output* args)))) + (when *debug* + (apply #'out (cons *error-output* args)))) + +(defun stdout (&rest args) + (apply #'out (list* *standard-output* args))) + +(defun println (&rest args) + (apply #'out (list* *standard-output* (str:concat (car args) "~%") (cdr args)))) (defun enumerate (ls &optional (first-index 0)) (loop for e in ls and i from first-index @@ -2320,18 +2551,28 @@ the code. \section{How to produce the binary executable} -Just say {\tt make exe} to your shell. +Just say {\tt make loop} to your shell. <>= -(load "~/.sbclrc") +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) (ql:quickload :loop :silent t) -(sb-ext:save-lisp-and-die #P"loop.exe" +(sb-ext:save-lisp-and-die #P"loop" :toplevel #'loop:main - :executable t) + :executable t + :save-runtime-options t) @ \section{How to update the remote server}\label{sec:live} +XXX: notice we don't include such targets in the [[Makefile]] +anymore. Now we use a [[Makefile.personal]] that we don't release +anymore. We may still keep this section as instruction, but we need +to update it to reflect the facts. + We automate here the process of updating and compilation of a new version of \lp. It's certain that what we document here is specific to a single UNIX system, but what's important is that you (dear @@ -2417,18 +2658,16 @@ variables in the chunks where it's used. But for someone reading global variables at the top of the file. That's something to think about. +<>= +:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon +:filesystem-utils +@ + <>= ;;; -*- mode: LISP; syntax: COMMON-LISP; package: LOOP; -*- (eval-when (:compile-toplevel :load-toplevel :execute) (ql:quickload - '(:lisp-unit - :str - :uiop - :cl-fad - :cl-ppcre - :local-time - :iterate - :clsql-sqlite3) + '(<>) :silent t)) (clsql:enable-sql-reader-syntax) @@ -2436,11 +2675,13 @@ about. (defpackage #:loop (:use :common-lisp :local-time) (:import-from :lisp-unit define-test) - (:import-from :iterate iter) + (:import-from :org.shirakumo.filesystem-utils + directory-p list-directories list-files) (:export :main)) (in-package #:loop) +<> <> <> <> @@ -2487,37 +2728,58 @@ about. <>= ;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*- (asdf:defsystem :loop - :version "0.0.1" - :description "An NNTP server for a group of friends." - :depends-on (:lisp-unit :str :uiop :cl-fad :cl-ppcre) + :version "<>" + :description "<>" + :depends-on (<>) :components ((:file "loop"))) -@ %def :loop +@ %def :loop loop.asd \section{The UNIX service} +XXX: this section should be informative only. We're going to suggest +users how to run the system. We may provide a [[make install]] target +that runs things the way we do, but this should be optional. Idea: +instead of hard coding a path to the service, make it {\tt conf-home} +or {\tt conf-service}. + +The installation is as follows. You clone the repo to your +local-projects, then run make build. This builds the executable. You +edit conf-home to choose your install directory. Then you say make +install which copies loop, accounts.lisp, the scripts and the service +directory. It is now the syadmin duty to do ln -s ./svc to +/service/loop, which runs it. Let's see if we can pull that off. + We use the {\tt tcpserver} program by Daniel J. Bernstein from the package \href{https://cr.yp.to/ucspi-tcp.html}{\tt ucspi-tcp}. -<>= -/home/dbastos/loop -@ %def - <>= 119 @ %def <>= #!/bin/sh +home=`head -1 conf-home` +cd $home +exec 2>1& echo loop -cd <> -exec <>/tcpserver -HR 0.0.0.0 <> <>/loop.exe +exec "$home"/tcpserver -HR 0.0.0.0 <> "$home"/loop @ %def -How should you update the server if you modified the source-code? See -Section~\ref{sec:live}. +<>= +#!/bin/sh +echo loop +exec /usr/bin/logger -i -t loop +@ \section{The writing process} +XXX: note to self. Targets [[make build]] and [[make install]] must +be completely non-dependent on noweb. Also, most users will not run +any web at all---they'll run noweb, so releasing {\tt any} use in the +Makefile makes no sense to users. I think we'll need to set up a +virtual machine to practice the use of real-world noweb for other +users. (Lots of work!) + The program {\tt latexmk} is iseful when I'm writing \LaTeX\ in general, but to get the attention of {\tt latexmk} we need to rewrite {\tt loop.tex}. So what I do while writing \lp\ is to have a diff --git a/peat b/peat deleted file mode 100644 index 5078c80..0000000 --- a/peat +++ /dev/null @@ -1,224 +0,0 @@ -#!/usr/bin/env python -# -*- coding: utf8 -*- - - ############################## - # ____ ___ ____ ______ # - # | \ / _] / T| T # - # | o )/ [_ Y o || | # - # | _/Y _]| |l_j l_j # - # | | | [_ | _ | | | # - # | | | T| | | | | # - # l__j l_____jl__j__j l__j # - # # - ##### ##### - # Repeat commands! # - ################## - -import errno, os, subprocess, sys, time -from optparse import OptionParser - - -interval = 1.0 -command = 'true' -clear = True -get_paths = lambda: set() -verbose = True -dynamic = None -last_run = None - - -USAGE = r"""usage: %prog [options] COMMAND - -COMMAND should be given as a single argument using a shell string. - -A list of paths to watch should be piped in on standard input. - -For example: - - find . | peat './test.sh' - find . -name '*.py' | peat 'rm *.pyc' - find . -name '*.py' -print0 | peat -0 'rm *.pyc' - -If --dynamic is used, the given command will be run each time to generate the -list of files to check: - - peat --dynamic 'find .' './test.sh' - peat --dynamic 'find . -name '\''*.py'\''' 'rm *.pyc' -""" - - -def log(s): - if verbose: - print(s) - -def die(s): - sys.stderr.write('ERROR: ' + s + '\n') - sys.exit(1) - -def check(paths): - for p in paths: - try: - if os.stat(p).st_mtime >= last_run: - return True - except OSError as e: - # If the file has been deleted since we started watching, don't - # worry about it. - if e.errno == errno.ENOENT: - pass - else: - raise - return False - -def run(): - global last_run - last_run = time.time() - log("running: " + command) - subprocess.call(command, shell=True) - -def build_option_parser(): - p = OptionParser(USAGE) - - # Main options - p.add_option('-i', '--interval', default=None, - help='interval between checks in milliseconds', - metavar='N') - p.add_option('-I', '--smart-interval', dest='interval', - action='store_const', const=None, - help='determine the interval based on number of files watched (default)') - - p.add_option('-d', '--dynamic', default=None, - help='run COMMAND before each run to generate the list of files to check', - metavar='COMMAND') - p.add_option('-D', '--no-dynamic', dest='dynamic', - action='store_const', const=None, - help='take a list of files to watch on standard in (default)') - - p.add_option('-c', '--clear', default=True, - action='store_true', dest='clear', - help='clear screen before runs (default)') - p.add_option('-C', '--no-clear', - action='store_false', dest='clear', - help="don't clear screen before runs") - - p.add_option('-v', '--verbose', default=True, - action='store_true', dest='verbose', - help='show extra logging output (default)') - p.add_option('-q', '--quiet', - action='store_false', dest='verbose', - help="don't show extra logging output") - - p.add_option('-w', '--whitespace', default=None, - action='store_const', dest='sep', const=None, - help="assume paths are separated by whitespace (default)") - p.add_option('-n', '--newlines', - action='store_const', dest='sep', const='\n', - help="assume paths are separated by newlines") - p.add_option('-s', '--spaces', - action='store_const', dest='sep', const=' ', - help="assume paths are separated by spaces") - p.add_option('-0', '--zero', - action='store_const', dest='sep', const='\0', - help="assume paths are separated by null bytes") - - return p - - -def _main(): - if dynamic: - log("Running the following command to generate watch list:") - log(' ' + dynamic) - log('') - - log("Watching the following paths:") - for p in get_paths(): - log(' ' + p) - log('') - log('Checking for changes every %d milliseconds.' % int(interval * 1000)) - log('') - - run() - - while True: - time.sleep(interval) - if check(get_paths()): - if clear: - subprocess.check_call('clear') - run() - -def smart_interval(count): - """Return the smart interval to use in milliseconds.""" - if count >= 50: - return 1000 - else: - sq = lambda n: n * n - return int(1000 * (1 - (sq(50.0 - count) / sq(50)))) - -def _parse_interval(options): - global get_paths - if options.interval: - i = int(options.interval) - elif options.dynamic: - i = 1000 - else: - i = smart_interval(len(get_paths())) - - return i / 1000.0 - -def _parse_paths(sep, data): - if not sep: - paths = data.split() - else: - paths = data.split(sep) - - paths = [p.rstrip('\n') for p in paths if p] - paths = map(os.path.abspath, paths) - paths = set(paths) - - return paths - -def main(): - global interval, command, clear, get_paths, verbose, dynamic - - (options, args) = build_option_parser().parse_args() - - if len(args) != 1: - die("exactly one command must be given") - - command = args[0] - clear = options.clear - verbose = options.verbose - sep = options.sep - dynamic = options.dynamic - - if dynamic: - def _get_paths(): - data = subprocess.check_output(dynamic, shell=True) - return _parse_paths(sep, data) - - get_paths = _get_paths - else: - data = sys.stdin.read() - paths = _parse_paths(sep, data) - - if not paths: - die("no paths to watch were given on standard input") - - for path in paths: - if not os.path.exists(path): - die('path to watch does not exist: ' + repr(path)) - - get_paths = lambda: paths - - interval = _parse_interval(options) - - _main() - - -if __name__ == '__main__': - import signal - def sigint_handler(signal, frame): - sys.stdout.write('\n') - sys.exit(130) - signal.signal(signal.SIGINT, sigint_handler) - main() - diff --git a/scripts/build-exe.lisp b/scripts/build-exe.lisp new file mode 100644 index 0000000..2d23f95 --- /dev/null +++ b/scripts/build-exe.lisp @@ -0,0 +1,10 @@ +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) +(ql:quickload :loop :silent t) +(sb-ext:save-lisp-and-die #P"loop" + :toplevel #'loop:main + :executable t + :save-runtime-options t) diff --git a/scripts/build-index-from-fs.lisp b/scripts/build-index-from-fs.lisp new file mode 100644 index 0000000..e6f9f68 --- /dev/null +++ b/scripts/build-index-from-fs.lisp @@ -0,0 +1,11 @@ +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) +(ql:quickload :loop :silent t) +(in-package #:loop) +(connect-index! "message-id.db") +(drop-create-index!) +(index-from-fs!) +(format t "Index built.~%") diff --git a/scripts/cron-remove-inactive-users.lisp b/scripts/cron-remove-inactive-users.lisp new file mode 100644 index 0000000..6d10913 --- /dev/null +++ b/scripts/cron-remove-inactive-users.lisp @@ -0,0 +1,11 @@ +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) +(ql:quickload :loop :silent t) +(in-package #:loop) +(read-accounts!) +(connect-index! "message-id.db") +(remove-inactive-users!) +(write-accounts!) diff --git a/scripts/migrate-add-creation-date.lisp b/scripts/migrate-add-creation-date.lisp new file mode 100644 index 0000000..f0fc880 --- /dev/null +++ b/scripts/migrate-add-creation-date.lisp @@ -0,0 +1,9 @@ +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) +(ql:quickload :loop :silent t) +(in-package #:loop) +(migrate-add-creation-and-post-date!) +(format t "Accounts rewritten.~%")