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.~%")