commit a104a2d8657b9c85eb04aec6261f298f643bf4b2 Author: Circling Skies Date: Thu Dec 5 18:23:19 2024 -0300 Fiat lux! diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..1dbc8dc --- /dev/null +++ b/Makefile @@ -0,0 +1,79 @@ +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) diff --git a/accounts.lisp b/accounts.lisp new file mode 100644 index 0000000..cadd35b --- /dev/null +++ b/accounts.lisp @@ -0,0 +1,9 @@ +(#S(LOOP::ACCOUNT + :USERNAME "ANONYMOUS" + :SEEN 3935609919 + :LAST-POST NIL + :FRIENDS NIL + :PASS 2335603191554807875 + :PASS-LOCKED NIL + :PASS-LOCKED-WHY NIL + :CREATION 3913066800)) diff --git a/build-exe.lisp b/build-exe.lisp new file mode 100644 index 0000000..cf687f8 --- /dev/null +++ b/build-exe.lisp @@ -0,0 +1,5 @@ +(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 new file mode 100644 index 0000000..531c769 --- /dev/null +++ b/build-index-from-fs.lisp @@ -0,0 +1,7 @@ +(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 new file mode 100644 index 0000000..788c1ba --- /dev/null +++ b/cron-remove-inactive-users.lisp @@ -0,0 +1,8 @@ +(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/groups/local.control.news/1 b/groups/local.control.news/1 new file mode 100644 index 0000000..adc869e --- /dev/null +++ b/groups/local.control.news/1 @@ -0,0 +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 diff --git a/groups/local.control.news/2 b/groups/local.control.news/2 new file mode 100644 index 0000000..8fb0618 --- /dev/null +++ b/groups/local.control.news/2 @@ -0,0 +1,7 @@ +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 new file mode 100644 index 0000000..9efd2e1 --- /dev/null +++ b/groups/local.control.news/3 @@ -0,0 +1,7 @@ +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 new file mode 100644 index 0000000..5108f91 --- /dev/null +++ b/groups/local.control.news/4 @@ -0,0 +1,7 @@ +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 new file mode 100644 index 0000000..6b578e6 --- /dev/null +++ b/groups/local.control.news/5 @@ -0,0 +1,7 @@ +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 new file mode 100644 index 0000000..ffe4546 --- /dev/null +++ b/groups/local.control.news/6 @@ -0,0 +1,7 @@ +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 new file mode 100644 index 0000000..a1f976f --- /dev/null +++ b/groups/local.control.news/7 @@ -0,0 +1,7 @@ +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 new file mode 100644 index 0000000..3aaf4f9 --- /dev/null +++ b/groups/local.test/1 @@ -0,0 +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. diff --git a/groups/local.test/1.~1~ b/groups/local.test/1.~1~ new file mode 100644 index 0000000..014728f --- /dev/null +++ b/groups/local.test/1.~1~ @@ -0,0 +1,7 @@ +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/images/gnus-summary.png b/images/gnus-summary.png new file mode 100644 index 0000000..a58f949 Binary files /dev/null and b/images/gnus-summary.png differ diff --git a/images/sylpheed-summary.png b/images/sylpheed-summary.png new file mode 100644 index 0000000..8b930e1 Binary files /dev/null and b/images/sylpheed-summary.png differ diff --git a/images/tbird-summary.png b/images/tbird-summary.png new file mode 100644 index 0000000..7eea48c Binary files /dev/null and b/images/tbird-summary.png differ diff --git a/loop.asd b/loop.asd new file mode 100644 index 0000000..3b6a768 --- /dev/null +++ b/loop.asd @@ -0,0 +1,14 @@ +;;; -*- 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"))) + diff --git a/loop.lisp b/loop.lisp new file mode 100644 index 0000000..4ea3067 --- /dev/null +++ b/loop.lisp @@ -0,0 +1,1194 @@ +;;; -*- 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!)) diff --git a/loop.nw b/loop.nw new file mode 100644 index 0000000..00f8d2a --- /dev/null +++ b/loop.nw @@ -0,0 +1,2565 @@ +% -*- mode: noweb; noweb-default-code-mode: lisp-mode; -*- +\documentclass[a4paper,11pt]{article} +\usepackage[text={6.75in,10in},centering]{geometry} + +\usepackage{graphicx} + +\usepackage[T1]{fontenc} +\usepackage[utf8]{inputenc} +\usepackage{csquotes} +\usepackage[brazil]{babel} + +\usepackage{etoolbox} +\AtBeginEnvironment{quote}{\small} +\AtBeginEnvironment{verbatim}{\small} + +%% \usepackage[backend=biber]{biblatex} +%% \addbibresource{refs.bib} +%% \renewcommand{\cite}{\parencite} +\usepackage[hyperref]{xcolor} +\usepackage[colorlinks=true,citecolor=]{hyperref} % linkcolor=red + +\usepackage{amsmath,amsthm,amssymb} +\allowdisplaybreaks +\usepackage{lmodern} +\usepackage{noweb} +\noweboptions{brazil,longchunks,smallcode} +\DeclareMathOperator{\mdc}{mdc} +\DeclareMathOperator{\gcdext}{gcdext} +\DeclareMathOperator{\remainder}{remainder} +\DeclareMathOperator{\quotient}{quotient} +\DeclareMathOperator{\diff}{diff} + +\def\nwendcode{\endtrivlist \endgroup} +\let\nwdocspar=\par + +%% Popular words. +\newcommand{\lxxp}{{\em loop}} +\newcommand{\Lp}{{\tt LOOP}} +\newcommand{\lp}{\Lp} +\newcommand{\bug}{{\em bug}} +\newcommand{\symlink}{{\em symbolic link}} +\newcommand{\symlinks}{\symlink s} + +\title{\Lp\\ + {a circle out of fashion}} +\date{January 2024} +\begin{document} +\fontfamily{cmr}\selectfont +\maketitle +%\setlength{\parskip}{3pt} +%\setlength{\parindent}{0pt} + +\Lp\ is an out-of-fashion program, used as medium of communication by +antiquated people. \Lp\ members insist that technical communication +be made in writing and not in a hurry. That's how backwards they are. +To give you an idea, they write \Lp\ in Lisp---jurassic technology. +We surely wouldn't pay them any attention. +% +\begin{verbatim} + Drunk and dressed in their best brown baggies and their platform soles + They don't give a damn about any trumpet-playing band + It ain't what they call rock and roll + -- Mark Knopfler, 1978. +\end{verbatim} + +It's easy to make a conference on the Internet. E-mail works. When +we write an e-mail to various friends to discuss a certain subject, we +form a circle. When we decide to add another person to this +quickly-made conference by e-mail, sometimes we use a well-known +idiom---``adding John to the loop''. We add John's e-mail address to +the list of destinaries. So long as everyone replies to everyone, +John, too, will start getting all the messages. If anyone violates +this rule of replying to everyone involved, the loop is broken. + +There are surely inconveniences in using e-mail as conference medium. +For example, after John has been added to the loop, he is not able to +leave by his own account. He needs to ask everyone involved to stop +writing to him. This is usually easy to do, but instead people tend +to ask for more technology such as mailing lists. A mailing list is +nothing by an automated version of this idea of writing to various +people at once. When the mailing address is written to, a program +resends the message to all subscribers of the mailing list and, this +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''. + +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 +NNTP-aware programs. You could write your own. Figures +\ref{fg:gnus}--\ref{fg:sylpheed} show a few programs for reading +network news via NNTP. + +\begin{figure}[!htb] + \centering \includegraphics[width=0.8\linewidth]{images/gnus-summary.png} + \caption{Gnus, a news reader embedded in the GNU EMACS text editor.} + \label{fg:gnus} +\end{figure} + +\begin{figure}[!htb] + \centering \includegraphics[width=0.8\linewidth]{images/tbird-summary.png} + \caption{Thunderbird, a news reader produced by the Mozilla Foundation.} + \label{fg:bird} +\end{figure} + +\begin{figure}[!htb] + \centering \includegraphics[width=0.8\linewidth]{images/sylpheed-summary.png} + \caption{Sylpheed, a news reader produced by Hiroyuki Yamamoto.} + \label{fg:sylpheed} +\end{figure} + +{\bf Principles for a discussion group}. We believe a discussion group +should be small and grow slowly. By ``slowly'', we mean that each +member comes in through an invitation. This way, the group being +closed by definition, we keep spam out and give members a certain +sense of privilege. + +A discussion group should be formed by interested people. If a +participant doesn't log-in for a certain period of time, \lp locks the +participant's account---see Section \ref{sec:inactive-users}. The +account can be reactivated, but it will take asking another +participant (with an active account) to do so. In other words, +there's an encouragement for an uninterested member not to come back +to the \lp. The idea is to keep a certain cohesion in the discussion +groups. When an account is locked or unlocked, an article is posted +to the group {\tt local.control.news}, so everyone knows who is +leaving and arriving. This way, participants get to have an idea of +who is reading them. + +Each invitation comes with a certain responsibility: it's possible to +see who invited who. If {\tt BOB} misbehaves, everyone gets to see +that {\tt ALICE} doesn't have nice friends. The {\tt USERS} command +shows the relationship graph: +% +\begin{verbatim} +USERS +200 List of current users: +ANONYMOUS, last seen on Fri Mar 8 19:01:56 2024, invited (ALICE) + ALICE, last seen on Sun Mar 10 21:25:45 2024, invited (BOB CARLA) + BOB, last seen on Sun Mar 10 21:17:30 2024, invited nobody + CARLA, last seen on Sun Mar 10 18:30:48 2024, invited nobody +\end{verbatim} + +We conjecture that a discussion group tends to prosper when each +member feels as important as any other member. So we think each +member should have as much managerial power as any other. In an +attempt to realize this ideal, each member is able to not only invite +other people---see the [[CREATE-ACCOUNT]] command---, but also to +create new groups---see the [[CREATE-GROUP]] command. + +Despite this introduction, this is not a tutorial on the history of +the Internet or how NNTP works. This is the source code of \lp. +Hereafter, our conversation continues in Lisp. Understanding how +\lp\ is made is only necessary if you intend to modify it. If you +just want to use the system, you probably should stop right here. + +\section{The implementation strategy}\label{sec:design} + +Anything a user sends to the \lp\ is wrapped in a [[request]] and +any command processing must produce a [[response]]: +% +\begin{verbatim} + request ---> process ---> response. +\end{verbatim} +% +The request arrives, \lp\ interprets it, finds out which command +should look at the request and then dispatches the the request to the +right command. The command process the request and returns a +response. Then \lp\ takes this response and sends it out back to the +user through the network using [[send-response!]]. That's all there +is to \lp. Everything else is just the details of this strategy. + +Before you investigate the source code of \lp, you should have {\tt + SBCL} installed---the Common Lisp compiler we've been using---and +the package [[:loop]]. This way you can interact with the system: +% +\begin{verbatim} +CL-USER> (ql:quickload :loop) +To load "loop": + Load 1 ASDF system: + loop +; Loading "loop" +.................. +(:LOOP) +CL-USER> (in-package :loop) +# +LOOP> (make-request "HELP") +#S(REQUEST :VERB "HELP" :ARGS NIL :SAID NIL) +\end{verbatim} +% +The procedure [[make-request]] constructs a [[request]]. When a user +connects to the \lp, each command sent by the user is packaged inside +a [[request]] structure like this one above. To see how \lp\ answers +this request for help, we can invoke the procedure [[dispatch]], which +is responsible to find the correct procedure to reply to the request. + +\begin{verbatim} +LOOP> (dispatch (make-request :verb "HELP")) +#S(RESPONSE + :CODE 400 + :DATA "unrecognized command" + :REQUEST #S(REQUEST :VERB "HELP" :ARGS NIL :SAID NIL) + :MULTI-LINE NIL) +\end{verbatim} + +It turns that \lp\ doesn't recognize the command. That's because we +only loaded the [[:loop]] package. The reason it doesn't recognize +the command is that the command table has not been built. Let's build +it and try again: + +\begin{verbatim} +LOOP> (set-up-tables!) +(("ARTICLE" + . #S(COMMAND + :FN # + :VERB "ARTICLE" + :DESCRIPTION "fetches full articles")) +[...] +("HELP" + . #S(COMMAND + :FN # + :VERB "HELP" + :DESCRIPTION "displays this menu")) [...]) + +LOOP> (dispatch (make-request :verb "HELP")) +#S(RESPONSE + :CODE 200 + :DATA (87 104 97 [...] 112) + :REQUEST #S(REQUEST :VERB "HELP" :ARGS NIL :SAID NIL) + :MULTI-LINE YES) +\end{verbatim} + +That's better. These numbers we see in the response are the bytes in +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 +XOVER fetches the overview database of a group" +\end{verbatim} + +This is the text that the user sees when they ask for {\tt HELP}. In +other words, the field {\tt data} in a [[response]] stores the data to +be delivered back to the user. The program {\tt nc}---for +``netcat''---that we use below is capable of opening a TCP connection +and handling that connection to our keyboard so that we can interact +with the \lp. You can effectively achieve the same thing using a +program such as {\tt telnet}. + +\begin{verbatim} +C:\>nc antartida.xyz 119 +200 Welcome! Say ``help'' for a menu. +help +200 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 +. +quit +205 Good-bye. +\end{verbatim} + +But keep in mind that \lp\ was not made to talk to users directly. +\Lp\ was made to talk to your NNTP client, programs such as the ones +illustrated by Figures \ref{fg:gnus}--\ref{fg:sylpheed}. That's why +we see these numbers in the responses given by \lp. These numbers are +there to help clients understand how the conversation is going. Each +specific such number is determined by the NNTP protocol. But, despite +the protocol being made for machines to talk to each other, it's +perfectly possible for a user to interact with \lp\ directly using a +keyboard and a command-line tool such as {\tt nc} or {\tt telnet}. In +fact, \lp\ takes advantage of that to be hackable. \Lp\ was written +so that it can talk to NNTP clients---such as Gnus, Sylpheed {\em et + cetera}---but also to users directly. Commands such as +[[CREATE-ACCOUNT]], [[CREATE-GROUP]], [[PASSWD]] are not part of the +NNTP protocol, so users need to know how to use {\tt nc} or {\tt + telnet} to take advantage of all of \lp's capabilities. + +\section{The NNTP protocol} + +An Internet protocol is usually defined by a document whose tradition +calls RFC---for ``[r]equest [f]or [c]omments''. The NNTP protocol is +defined by RFCs 977, 2980, 3977, 4643 and 5536. RFC 977 was the first +and replaced by 3977. Still, reading RFC 977 is interesting precisely +because it gives us a historical account of the protocol, making it +easier to understanding the evolution of the system. The objective of +RFC 2980 was to implement new ideas to the NNTP protocol---to extend +the protocol. RFC 3977 adopts some of these extensions. RFC 4643 +also extends RFC 2980---addressing concerns with authentication. + +\section{It's a network server} + +The \lp\ program is a network server, that is, it serves connections +on the network. However, instead of implementing the handling of TCP +connections, we use what is called a ``TCP superserver'' or ``TCP +wrappers'' or perhaps just ``TCP server''. The idea is---a program +called ``TCP server'' waits for connections from the network. When a +client arrives, the TCP server handles the network connection to \lp. +From \lp's perspective, the client is just another keyboard talk to it +directly. This strategy simplifies the implementation of \lp. Both +programs---the TCP server and \lp---have nothing to do with one +another, but their work together make the system work. This +implementation strategy is typically found in UNIX programs. +% +\begin{quote}\small +This is the Unix philosophy. Write programs that do one thing and do +it well. Write programs to work together. Write programs that handle +text streams, because that is a universal interface.\\ -- Doug +McIlroy, 1989, interviewed by Michael S.~Mahoney. +\end{quote} +% +The TCP server just just one thing---listens for new connections and +handles them to the interested program. It does the handling and does +it well. \Lp, on the other hand, concerns itself with the NNTP +protocol and does not worry about handling network connections. This +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 representation of a client} + +How do we represent a client? A client is typically reading a group +and an article; it's has authenticated itself or not yet. So we need +a global structure to annonate the client's state. + +<>= +(defstruct client group (article 1) (username "ANONYMOUS") (auth? 'no)) +(defparameter *client* (make-client)) +@ %def client *client* + + +\section{The representation of a command} + +What does a client typically tell \lp? A client typically sends +commands. Commands typically need arguments. Each command is +dispatched to a procedure that answers it---it's the purpose of +\verb|fn| in the command. Together, all commands make up a table of +commands, which is essentially what the user sees when ask for +\verb|HELP|. (Be aware that some clients use the output of +\verb|HELP|. For example, Gnus v5.13.) + +<>= +(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))))) +@ %def *commands-assoc* set-up-tables! get-command + +\section{The representation of requests and responses} + +Each command is given through a text line written by the user. Let's +call this text line the [[request]]. When \lp\ parses the request, it +will extract (from the request) a verb and some arguments. We will +take a verbatim copy of everything the user has said, possibly for +debugging purposes. + +How do we represent a [[response]]? A [[response]] is always a +reaction to a [[request]]. The NNTP protocol always specifies an +integer as the code to a response, which is what we call the +\verb|code| in the response. Long responses end with a period and we +mark such responses with [[multi-line]]. + +<>= +(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))) +@ %def request response make-response make-request empty-response prepend-response-with + +Here's how to send a [[response]] to a client. + +<>= +(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) +@ %def send-response! + +The Windows Console---the one we use when we run {\tt cmd.exe}---makes +the Lisp procedure [[write-sequence]] produce UCS-2. Windows will do +what we need of [[write-sequence]] if we're not operating \lp\ on the +Windows Console. Recall that we do not run \lp\ on Windows Console, +so whatever happens because of it is of little importance to us. +However, we implement \lp\ on Windows and so it's convenient for us +that \lp\ and Windows play nicely with each other. A cheap solution +here is to simply convert the bytes to a string if \lp\ is directly +connected to an interactive Lisp stream. This way we effectively +eliminate the UCS-2 encoding used by Windows. It is perfectly fine +for us to destroy the encoding of articles while we're writing \Lp. +It is not fine, however, when it's running in production. But, in +production, {\tt (interactive-stream-p s)} will always be false. How +else should we handle this? + +<>= +(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))) +@ %def my-write + +\section{The parsing of requests} + +The commands themselves we call {\tt verbs} and everything else the +user types we call {\tt args}. Observe that upper and lower case +letters are equivalent in request verbs. + +<>= +(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)))))) +@ %def parse-request + +\section{The main loop} + +Every command consumes a [[request]] and produces a [[response]]. If +any procedure always produces a [[response]], then delivering a +[[response]] to the user is a matter of sending a string composed of +the [[response]] code contacated with the [[response]] data. + +What does \lp\ do? It repetitively reads a line from the user, +processes that line and always replies something back. Then \lp\ is +back at waiting for the user to say something else again. If the user +says {\tt QUIT}, then we should identify it and terminate \lp's +execution. That's even [[send-response!]] returns the [[request]] +itself---so we can cascade actions based on a user's request. + +<
>= +(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."))) +@ %def main main-loop + +\section{The request dispatching mechanism} + +Dispatching requests means consuming one and invoking the correct +procedure that will process the request. The invoked procedure must +produce a [[response]]. The work of dispatching is just delivering +the task to an response-producing procedure and then raising the +response to whoever needs to catch it. For example, +[[response-quit?]] is used by [[main-loop]] to identify when the user +has issued {\tt QUIT}, in which case we terminate [[main-loop]]. + +<>= +(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)))) +@ %def dispatch dispatch-line + +\section{The representation and parsing of articles} + +An article is made of two parts, the head and the body. We do need to +parse the head, but we never parse the body: we don't want to +intervene in anything that a user might be doing in the body of the +article. The headers, however, are mostly under the jurisdiction of +the server. This decision is due to the fact servers must read +headers. For example, how do we know to which groups an article was +posted? We look at the header {\tt newsgroups}. So, the server must +understand the encoding of headers. Therefore, we assume ASCII +encoding of all headers that we need to parse. + +The member [[headers]] of the structure [[article]] is just a string, +while body is a vector of bytes. To get a list of pairs out of the +set of all headers of an article, we can ask [[parse-headers]]. Yes, +I should've called the member [[headers]] as [[head]] and not +[[headers]] because both the word ``headers'' and its plural used here +suggest a list of parsed headers. We're going to rename this in due +time. %% TODO + +<>= +(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))) +@ %def parse-article parse-headers + +We now write some procedures that we use when we're build the {\em + overview} of the command \verb|XOVER|. + +<>= +(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))) +@ %def get-header fetch-headers + +\section{How to extract articles from the database} + +Notice that we do not care about which encoding is used in articles. +We just read the article bytes and handle them to the client. It's +the article viewer's---the NNTP client's, that is---responsibility of +interpreting such bytes. That's why we call [[read-sequence]] here. + +<>= +(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)))) +@ %def fetch-article + +The purpose of [[encode-body]] is to eventually worry about the +appearance of a period on a line by itself in the middle of an +article. Since ``\verb|.\r\n|'' is part of the NNTP protocol, we must +handle this gracefully---but notice we have not done anything about +that so far. So we are essentially writing a bug right here. + +<>= +(defun encode-body (a) a) +@ %def encode-body + +The procedures [[extract-mid]] and [[lookup]] also belong belong in +this section. Notice that I also wrote [[mid-by-name]], which should +merge with [[extract-mid]]. I think I also wrote more +redundancies---perhaps in the implementatio nof [[xover]]---for not +using [[lookup]]. I need to seek out all such places and organize. %% TODO + +<>= +(defun extract-mid (a) + (lookup "message-id" (parse-headers (article-headers (parse-article a))))) +(defun lookup (key table) + (cdr (assoc key table :test #'string=))) +@ %def extract-mid lookup + +\section{The commands} + +\subsection{{\tt HELP}} + +When someone asks for help, we present a table of commands. The table +construction is made by [[menu]]. The procedure [[menu]] was one of +the first things I wrote. (This is my first program written in Common +Lisp.) I didn't want to get involved with the famous [[loop]] macro, +so I used recursion in [[menu]]\footnote{I'd like to isolate these +auxiliary procedures inside a single function that uses them. Common +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 + +<>= +(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)))) +@ + +\subsection{{\tt AUTHINFO}}\label{sec:authinfo} + +The implementation of {\tt AUTHINFO}. When we connect to +\lp\ directly from a keyboard, it's a bit painful to authenticate with +two commands---{\tt AUTHINFO user} and {\tt AUTHINFO pass}. So we +also implemented the command {\tt LOGIN}---see +Section~\ref{sec:login}. To check the user's password, we use the +procedure [[pass?]] that's defined in the implementation of {\tt + PASSWD}. Perhaps we should have called it {\tt + is-password-correct?} or something more obvious. + +<>= +Syntax error. Say ``authinfo USER /your-name/'' then ``authinfo PASS /your-pass/''. +@ + +<>= +(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 "<>")))))))) + +(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!)) +@ %def auth? log-user-in! + +\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)) + +<>= +(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))))) +@ %def CREATE-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 +[[accounts.lisp]]. The process that loses the race will have its +modifications lost. What do we need to do? Either we use file +locking or we do something smarter without a real file locking +mechanism. It's not clear to me what is possible here, but this is +definitely a problem that we need to solve. + +<>= +(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)))) +@ %def read-accounts! write-accounts! get-account + +\subsection{{\tt UNLOCK-ACCOUNT}} + +Inactive accounts are removed or locked---see Section +\ref{sec:inactive-users}. When an account is locked, any member can +unlock it. + +<>= +(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))))) +@ %def unlock-account! + +\subsection{{\tt LOGIN}}\label{sec:login} + +Besides {\tt AUTHINFO} in Section~\ref{sec:authinfo}, we also +implement a more convenient command for authenticationwhen we interact +with \lp\ through a command-line interface. Instead of having to say +two commands, we can just say {\tt login user password}. + +<>= +(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!)) +@ %def log-user-in-as! + +\subsection{{\tt PASSWD}}\label{sec:passwd} + +A change of password is made with {\tt PASSWD current new}. Observe +that we are duplicating code from other command procedures. I think +there is a macro emerging here called [[with-upcase-args]]. %% TODO + +<>= +(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!))) + +@ %def PASSWD pass? change-passwd! + +\subsection{{\tt USERS}}\label{sec:users} + +The tree of users and their friends is public. Anyone can know who +invited who. + +<>= +(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)))))) +@ %def list-users last-time-seen size-of-longest-username + +\subsection{{\tt LIST}}\label{sec:list} + +The database of groups and articles is a UNIX directory. We just need +to discover which directories exist and produce a listing. The heavy +work here is finding the index interval of articles in the group. (I +think we should already be optimizing this by merely caching the +information in a file that is read at start-up. I think we should +even cache the overview of the group.) %% TODO + +<>= +(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)))) +@ + +In [[basename]], what we want to do is---if the path ends with a +slash, we invoke [[pathname]]. Otherwise, we invoke {\tt + file-namestring}. + +<>= +(defun basename (path) + (let ((s (str:collapse-whitespaces path))) + (if (char= #\/ (last-char s)) + (car (last (pathname-directory s))) + (file-namestring s)))) +@ %def get-articles group-high-low + +\subsection{{\tt GROUP}}\label{sec:group} + +We just need to verify if the group exists and modify [[*client*]]. + +<>= +(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)) +@ %def group? + +Why have I written {\tt group?} and {\tt xgroup?}? There's probably a +clean-up task here. %% TODO + +\subsection{{\tt BODY}, {\tt HEAD}, {\tt ARTICLE} e {\tt NEXT}} +\label{sec:typical-cmds} + +Here we have an illustration of the expressive power of first-class +procedures. We want to implement the commands {\tt BODY}, {\tt HEAD}, +{\tt ARTICLE} and {\tt NEXT}. The ways to invoke them are (1) with no +argument, (2) with a single integer argument and (3) with a text +argument. In case (1), we use the number of the current +article---which is kept in [[*client*]]. In case (2), the NNTP client +specifies the article number. In case (3), the NNTP client specifies +the exact {\tt message-id}, which forces us to query the index---see +Section~\ref{sec:index} for the implementation of the index. + +<>= +(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)))))) +@ + +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|. + +<>= +(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))))))) +@ %def typical-cmd-response + +The command \verb|NEXT| has a slight different semantics. + +<>= +(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))) +@ %def cmd-next article-next! mid-by-name + +\subsection{{\tt XOVER}}\label{sec:xover} + +The procedure [[cmd-xover]] is used to figure out what the user said. +Once we have that figured out, we invoke [[xover]], which finishes the +work. Notice that when the argument [[to]] from [[xover]] is [[NIL]], +then the user is asking for articles indexed from the integer [[fr]] +to the last one. + +<>= +(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")) +@ + +\subsection{{\tt MODE READER}}\label{sec:mode-reader} + +So, we're always in reader mode, so we just ignore this command. + +<>= +(defun cmd-mode (r) ;; Whatever. + (make-response :code 200 :request r :data "Sure thing.")) +@ %def + +\subsection{{\tt DATE}}\label{sec:date} + +It's always useful to know the time and date at a computer. We should +surely format it a bit better than what {\tt now} does. + +<>= +(defun cmd-date (r) + (make-response :code 201 + :request r + :data + (format-timestring nil (now)))) +@ %def + +\subsection{{\tt QUIT}}\label{sec:quit} + +The use of {\tt QUIT} has a conection to [[main-loop]]: when the user +says {\tt QUIT}, [[main-loop]] must terminate. + +<>= +(defun cmd-quit (r) + (make-response :code 205 :data "Good-bye." :request r)) +@ %def + +\subsection{{\tt DD}}\label{sec:dd} + +The command {\tt DD} means ``[d]isplay client [d]ata structures''. It +shows to the client the internal state of how the server sees it. +I've used only for debugging and it's not really useful any longer. +I'm going to remove this very soon. + +<>= +(defun cmd-dd (r) + (make-response :code 200 :data (format nil "state: ~a" *client*) :request r)) +@ %def + +\subsection{{\tt POST}}\label{sec:post} + +If the client says {\tt POST}, then we continue to read line after +line until we find \verb|".\r\n"|. Having done that, we must check +whether we have a conformant article at hands. The definition of +conformant is given by [[conforms?]]. In a few words, the article +must have \verb|message-id|, \verb|subject|, \verb|from|, +\verb|newsgroups|. If the client doesn't provide us with a +\verb|message-id|, then \lp\ adds one. (Similarly for \verb|date|.) + +<>= +<> +(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))) +@ + +Sometimes we parse an article and sometimes we want to undo that +parsing. Am I doing something wrong? I wonder. %% TODO + +<>= +(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))) +@ %def unparse-article + +If an article being posted has no \verb|message-id| or \verb|date|, +\lp\ provides these headers. We kill these two rabbits with +[[ensure-header]], but we should probably make a table of headers and +procedures that would generate such headers if they're missing. Right +now, however, we have only these two to worry about. + +<>= +(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)) +@ %def ensure-mid ensure-date + +Now it's time to look at the header \verb|newsgroups|. (XXX: Our code +here is a bit confusing, but I don't know the best to do here, so I'm +going ahead unpretentiously.) If we get approved by [[conforms?]], +then we verify the list of newsgroups right away. + +The name of each group must conform to the expression + +<
>= +^([a-z0-9]+) +@ %def the-form-of-newsgroup-names + +I think people should have total freedom in naming groups. If users +create groups that mess up the local organization, then people should +discuss the matter and find a solution. Let's let people mess it up +instead of trying to stop them---the way of the hacker. + +<>= +(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."))))))) +@ %def post + +XXX: Oh, have a look at that. We accept the article even if there are +invalid groups. We should not do that. A user might only want to +post at all if his message is cross-posted to a few groups. A user +might easily mistype a group name. The Right Thing here is more +likely to stop posting completely with an error message telling the +user to either remove the invalid group of type it up properly. + +<>= +(defun update-last-post-date! (username) + (let ((u (get-account username))) + (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. + +<>= +(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))) +@ + +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. + +<>= +(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))) +@ + +{\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 +we need to do here is to use [[vector-push-extend]]. But this is to +be done in [[nntp-read-line]]. I hope to be able to get a faster +procedure in [[nntp-read-line]] and keep [[nntp-read-article]] as it +is. This is important to speed up posting. For instance, if we allow +attachments (which we don't), the performance penalty is clearly +noticeable. %%TODO + +<>= +(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))))))) +@ %def nntp-read-article + +The NNTP protocol establishes that line termination is done with +\verb|\r\n|, but it's useful to support UNIX line terminations, too, +because we are using the command-line and interact directly with the +server using tools that will not always send \verb|\r\n| as line +termination. For example, when someone is typing directly from the +keyboard and insert an empty line, we need the {\tt (and acc ...)} +because sometimes the list [[acc]] comes out empty. But an empty line +never comes from the NNTP protocol because there's is always a {\tt + CR} before {\tt LF}, but that's not true when someone is using the +keyboard directly. + +<>= +(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)) +@ %def nntp-read-line nntp-read-article + +{\bf Does the article conform?} RFC 5536 obliges every article to +have exactly \verb|date|, \verb|from|, \verb|message-id|, +\verb|newsgroups|, \verb|path| and \verb|subject| headers. The +headers \verb|path| is \Lp's responsibility, but it's used only in a +network of servers---so we're leaving that out for now. The header +\verb|message-id| is added by \Lp\ if the client doesn't write it +itself. + +Let's criticize the writing of [[conforms?]]. We have a [[catch]] +here and a [[throw]] in [[parse-headers]]. We also have a [[return]] +here. It's getting hard to read this procedure because it's not easy +to know that a procedure has to return a certain value to match the +expectation of another procedure. I don't remember what [[catch]] +does. I need to review this and then add the explanation for myself. +If I don't remember how this works, other beginners won't know it +either. %% TODO + +<>= +(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")) +@ %def conforms? + +Notice that up to this point we've only verified if the necessary +headers are present. The \verb|newsgroups| header is a direct +influence to the article storage. For instance, \verb|newsgroups| +must mention only groups that exist. When we save the article, we +check each group. If at least one group exists, we save the article; +if at least one group doesn't exist, we report to the user all groups +that don't exist, but we do save the article if at least one does +exist. That's probably not the best thing to do. We should probably +warn the user that one group doesn't exist because that could make all +the difference to the user. For instance, someone might decide not to +post at all if they can't cross post to all the groups they wish to. +One typo in one group name and the article would be posted to some +groups, but not to the misstyped one. We need to change this. %% TODO + +Also, do notice that to simplify matters we're duplicating articles +cross-posted. What we should do is write the article to the first +group in the list of \verb|newsgroups| and then make a symbolic link +to all others. The problem is that I don't know how to do that on +Windows. I'm not sure if Windows supports symbolic links at all. We +could perhaps duplicate articles only when on Windows. %% TODO + +\subsection{{\tt CREATE-GROUP}} + +We allow every user to create their own groups. (Are we crazy?) When +someone craetes a group, we post an article to {\tt + local.control.news} notifying everyone that a new group has been +created. People then have a chance to subscribe to the new group. We +assume that when someone creates a group, it's either no problem at +all or it has been discussed with the community beforehand. + +<>= +(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 "<>" g))) + (if okay? + (values t nil) + (values nil "must match <>")))) +@ %def CREATE-GROUP group-name-conforms? + +\section{The publication of news} + +If you're interested in being notified about what's going on in the +\lp, then subscribe to {\tt local.control.news}. Group creation, +invitations {\em et cetera} are published there. + +<>= +(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))) +@ %def notify-group-created notify-user-created + +\section{The algorithm of {\tt split-vector}} + +How should we describe the algorithm of [[split-vector]]? The +objective is to consume lists of bytes such as +[[(1 2 3 13 10 4 5 6 13 10 7 8 9)]] and produce lists of bytes +such as [[((1 2 3) (4 5 6) (7 8 9))]]. We use [[search]] to find [[13 10]]. +When we find this line termination, we have its position in the +consumed list. With the position, we collect the line and we iterate +searching for the next line. + +<>= +(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)))))))) +@ %def split-vector + +\section{The index article}\label{sec:index} + +Every NNTP server needs to have an index of articles. Each article is +indexed by its message-id. For example, the article +% +\begin{verbatim} + From: Eva Lu + Newsgroups: comp.unix + Subject: xv6: an introduction + Date: Wed, 24 Jul 2024 22:42:50 -0300 + Message-ID: <87plr25js5.fsf@tor.soy> + Cancel-Lock: sha1:82E8hqL1D1WQ9xc+CfnEYbFAaJo= + MIME-Version: 1.0 + Content-Type: text/plain; charset=utf-8 + Content-Transfer-Encoding: 8bit +\end{verbatim} +% +is indexed by the header {\tt message-id}. If you ask for article +{\tt <87plr25js5.fsf@tor.soy>}, \Lp\ will tell you that you can find +the article in group {\tt comp.unix} and its numeric ID is 37. Note +that the number 37 is not inside the article, but only in the name of +the file stored in the file system. The index, therefore, knows in +which file is each {\tt message-id}. This fact implies that you +cannot rename files in the file system---of course not: you'd changing +identifiers inside a database. If you have rename a file, you will +need to rebuild the index. Given that the index is an SQL table, you +can adjust the index relative to the any files you may need to rename +for whatever reason. You can also rebuild the entire index by reading +the file system---unless you have a lot of files, that's probably the +easiest thing to do. + +The use of [[*default-database*]] by the library [[clsql]] is very +convenient for us: we don't need to specify with which database we're +working. Since we work with only one, we pretty much never need to +specify anything. + +<>= +(defvar *default-database* nil) +@ %def *default-database* + +<>= +(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!)) +@ %def create-index! remake-index! connect-index! + +Of course, the creation and connection of the index must occur before +[[main-loop]], so it takes place in [[main]]. + +When someone requests an article, it's either by its numeric index but +then the client has already chosen a group, or it's by its {\tt + message-id}. We don't need to tell the client to which groups the +article belongs; we just give the entire article to the client. It +is, therefore, the client's responsibility what to do with the +article. However, to fetch an article, we need to know where in the +database (in the file system) is the article; in other words, we must +know one group in which the article was stored. This implies that the +index must know at least one group. We've decided to always index the +first group in the {\tt newsgroups} header. So the index's anatomy is +$(m, g, i)$, where $m$ is the {\tt message-id}, $g$ is the name of the +group and $i$, is the name of the article in the file system. This +also defines the anatomy of the SQL table. + +Should we store more information in the index? Not really. If we +need anything about an article, we can get it after we fetch it from +the file system. For example, suppose that a search command wishes to +display the fact that article was posted in various groups. Suppose +further the command has already located in the index an article to be +displayed. This means the command has the {\tt message-id} and one of +the groups in which the article was posted. The command is then able +to fetch the entire article from the file system. Now it's a matter +of reading the article itself to know almost everything there is to +know about it. (It's also interesting that we keep the index thin +because we need to allow it to grow to great sizes.) + +%% (clsql:create-table "INDICES" '(([id] (string 1000)) ([grp] (string 1000)) ([article] (string 300)))) +%% (clsql:execute-command "create table if not exists indices (id varchar(1000), grp varchar(1000), article varchar(300))") + +%% LOOP> (clsql:create-index "idx_id_1" :on "indices" :attributes "id" :unique "id") +%% ; No value +%% (clsql:execute-command "CREATE UNIQUE INDEX if not exists idx_id_1 ON INDICES (ID)") + +%% CL-USER> (clsql:list-attributes "indices") +%% ("ID" "GRP" "ARTICLE") + +%% CL-USER> (clsql:insert-records :into "indices" :attributes '(id grp article) :values '("<87plr25js5.fsf@tor.soy>" "comp.unix" 37)) +%% ; No value + +%% CL-USER> (clsql:select 'id 'grp 'article :from "indices") +%% (("<87plr25js5.fsf@tor.soy>" "comp.unix")) +%% ("ID" "GRP") + +\section{Essential operations relative to the index} + +Here's how to query the index or how to insert a new article into it. +If [[insert-index]] returns [[nil]], then it's because it found no +errors at all. The return value, therefore, indicates which error +ocurred. + +We don't consider an error that an article has already been added to +the index. For instance, we write multiple messages to the storage +when someone cross-posts, but we'll add just a single record to the +index, of course. So, an article already indexed is normal situation. +Sure---in the future, we will not duplicate articles in storage; we +will make symbolic links. We don't do that right now because Windows +doesn't really support symbolic links. + +<>= +(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)))) +@ %def insert-index lookup-index + +\section{A procedure to import the index from the file system} + +%% get group: +%% (first (last (pathname-directory (car (in-groups (directory "**/*")))))) + +%% get article name: +%% (pathname-name (car (in-groups (directory "**/*")))) + +%% get all articles +%% LOOP> (in-groups (directory "**/*")) + +%% get the newsgroup header from the article +%% LOOP> (get-header-from-article "newsgroups" (fetch-article "comp.lang.lisp" "1")) + +When we build the index from scratch, it's important to have a +procedure capable of reading all articles in the file system and index +them one by one. This is what we implement right here. For each news +group, we get the name of the file relative to the article---that's +the numeric ID of the article---and its {\tt message-id}. That's all +we need to index it. + +<>= +(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!)) +@ + +Here's a program to build the index from a UNIX shell. + +<>= +(load "~/.sbclrc") +(ql:quickload :loop :silent t) +(in-package #:loop) +(connect-index! "message-id.db") +(remake-index!) +(index-from-fs) +(format t "Index built.~%") +@ + +Be careful when using this program: it will build the database +[[message-id.db]], which is an operation that needs to be done only +once. Here's how to use it: +% +\begin{verbatim} +%pwd +/home/dbastos/loop + +%sbcl --script build-index-from-fs.lisp +Index built. + +%ls -l message-id.db +-rw-r--r-- 1 dbastos wheel 65536 Aug 26 13:32 message-id.db +\end{verbatim} + +\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. + +The program [[cron-remove-inactive-users.lisp]] can be executed every +day at midnight, say. + +<>= +(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!) +@ %def cron-remove-inactive-users.lisp + +In [[remove-account]], we probably should use [[delete-if]] as well on +the list of friends since it is effectively what we are doing there +with [[setf]]. %% TODO + +<>= +(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)))) +@ %def remove-account! remove-friend + +Accounts that do not have a creation date up until today---Tue Sep 17 +21:37:18 ESAST 2024---will have its creation dates migrated to the +\Lp\ epoch, which is January 1st 2024, the exact month in which +\Lp\ was written. But notice that this migration is done only once. +New system administrators of \Lp\ will never need to run this. + +<>= +(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!)) +@ %def migrate-add-creation-and-post-date! loop-epoch + +Here's a program to run the migration in a UNIX shell. + +<>= +(load "~/.sbclrc") +(ql:quickload :loop :silent t) +(in-package #:loop) +(migrate-add-creation-and-post-date!) +(format t "Accounts rewritten.~%") +@ %def migrate-add-creation-date.lisp + +Now we write the procedures that discover what accounts are inactive. + +<>= +(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))))) +@ %def list-inactive-users + +\section{A special-purpose language to ease writing}\label{sec:dsl} + +These macros make up a tiny language to ease the writing of \lp. For +example, when we need to access the group database, we use +[[in-groups]]. When a certain command demands authentication, we use +[[with-auth]]. + +<>= +(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))) + +@ %def in-groups with-group with-n-args with-group-set with-auth + +\section{Other procedures} + +Of small importance, they have nothing. Notice that [[ucs-2->ascii]] +is iseful only in Windows systems---and just for development. The +procedure destructively converts UCS-2 to ASCII, so it's only really +useful when we're converting an implicitly ASCII-content in the form +of UCS-2. Despite the name UCS-2, notice it is UTF-16. The name UCS +stands for ``Universal Character Set'' and I speculate the number 2 +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 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)) +@ %def bad-input crlf mkstr data crlf-string flatten ucs-2->ascii enumerate + +\section{Tests} + +I studied the minimum to be able to add these tests as we comprehend +better the direction in which we're going. A test system is essential +for us to trust we can move forward without breaking past decisions in +the code. + +<>= +(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))))) +@ %def + +\section{How to produce the binary executable} + +Just say {\tt make exe} to your shell. + +<>= +(load "~/.sbclrc") +(ql:quickload :loop :silent t) +(sb-ext:save-lisp-and-die #P"loop.exe" + :toplevel #'loop:main + :executable t) +@ + +\section{How to update the remote server}\label{sec:live} + +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 +reader) see exactly what must be done to go live with the system. + +The system is composed of the Lisp package [[loop]]. +The first thing to do is copy the files of each package to their +destinations in the remote server. The system depends on +[[quicklisp]] and we use the directory called [[local-projects]] as +the repository of our packages. So we just need ask {\tt ssh} to copy +the files. We begin with [[make]] to extract all source files from +[[loop.nw]], which is the master source code of \lp. +% +\begin{verbatim} +%scp loop.asd loop.lisp me@remote:quicklisp/local-projects/loop +loop.asd | 0 kB | 0.2 kB/s | ETA: 00:00:00 | 100% +loop.lisp | 37 kB | 37.5 kB/s | ETA: 00:00:00 | 100% +\end{verbatim} + +Files copied. Now it's time to produce the executabler from the newly +installed source code. To produce the executable, we run +[[build-exe.lisp]]. I'm going to demonstrate how to run this from my +own development machine. Since I'm running Windows, I use [[plink]] +and not [[ssh]]. +% +\begin{verbatim} +%scp build-exe.lisp me@remote:loop/ +build-exe.lisp | 0 kB | 0.2 kB/s | ETA: 00:00:00 | 100% + +%plink -ssh me@remote cd loop/ && sbcl --script loop/build-exe.lisp \ + echo "Executable built." +\end{verbatim} + +Produce the executable is sufficient because we're using Daniel +J. Bernstein's [[tcpserver]]. After replacing the executable in the +file system, new TCP connections will invoke the new executable while +older connections still alive will keep using the older executable +already loaded in memory. There's nothing to restart, in other +words. + +The target [[live]] in the [[Makefile]] automates the steps that we +have just described. Have a look at the [[Makefile]], which is not +included here in this literate document. With this automation, we +update the remote system with: +% +\begin{verbatim} +%make live +scp loop.asd loop.lisp \ + dbastos@antartida.xyz:quicklisp/local-projects/loop +loop.asd | 0 kB | 0.2 kB/s | ETA: 00:00:00 | 100% +loop.lisp | 37 kB | 37.5 kB/s | ETA: 00:00:00 | 100% +scp build-exe.lisp \ + dbastos@antartida.xyz:loop/ +build-exe.lisp | 0 kB | 0.2 kB/s | ETA: 00:00:00 | 100% +plink -ssh dbastos@antartida.xyz cd loop/ && \ + sbcl --script build-exe.lisp && \ + echo "Executable built." +Executable built. +\end{verbatim} + +Yes, we could parameterize the command with the address of the remote +server and remote path to the installation. But perhaps we will +always be the ones using this system, so we will delay this task until +further notice. %% TODO + +\section{The package {\tt loop.lisp} as the compiler needs it} + +We now put together all source code chunks in the order the compiler +needs to read it. By the way, you see this call to +[[enable-sql-reader-syntax]]? We need it at the top-level of any file +that uses the SQL syntax from [[clsql]]. You can see an illustration +of the syntax in, for example, [[lookup-index]]. + +One thing to keep in mind here is---I wonder if people that might read +this source code would read the literate programming \LaTeX\ output or +would they read [[loop.lisp]] directly. For literate programmers, it +doesn't matter how [[loop.lisp]] turns out because only the compiler +reads [[loop.lisp]]. But if we care about anyone who might read +[[loop.lisp]], then we should perhaps tell our literate programming +tools to generate a nice-looking file. For instance, I declare global +variables in the chunks where it's used. But for someone reading +[[loop.lisp]] directly, it is perhaps better if they would see all +global variables at the top of the file. That's something to think +about. + +<>= +;;; -*- 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) + +<> +<> +<> +<> +<> +<> +<> +<> +<> +<
> +<> +<
> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +@ %def + +<<*>>= +<> +<> +<> +<> +@ + +<>= +;;; -*- 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) + :components ((:file "loop"))) +@ %def :loop + +\section{The UNIX service} + +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 +echo loop +cd <> +exec <>/tcpserver -HR 0.0.0.0 <> <>/loop.exe +@ %def + +How should you update the server if you modified the source-code? See +Section~\ref{sec:live}. + +\section{The writing process} + +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 +program---called \href{https://github.com/sjl/peat}{[[peat]]} by Steve +Losh---monitor the NOWEB source code {\tt loop.nw} effectively +invoking [[latexmk]] whenever {\tt loop.nw} is modified. Have a look +at the target [[livedoc]] in the [[Makefile]]. + +\section{Why isn't {\tt Makefile} in {\tt loop.nw}} + +I don't include {\tt Makefile} in the literate source code because I +use [[make]] to drive the literate programming tools. It is true that +we could include the {\tt Makefile}, then run {\tt noweb} once to +extract the {\tt Makefile} from {\tt loop.nw} and then use [[make]] +after that. However, I prefer to build a package that's totally +independent from the literate programming tools because, more often +than not, literate programming tools are usually unavailable in the +typical UNIX system out there. This way, the package we offer the +public can be considered a typical UNIX source code package and +programmers need only worry about literate programming tools if they +decide to modify the source code. + +The way I particularly run {\tt noweb} is always by asking for +specific chunks to be extracted. So the command line I'd usually +write is, for example, +% +\begin{verbatim} +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 +\end{verbatim} +% +In other words, I dump the chunk into a temporary file so that I don't +destroy the previous version of the source code unless the extraction +produces no error. This is too long of a command line and should be +issued by [[make]] itself. + +\section*{Index of chunks} +\nowebchunks + +\section*{Index of names} +\nowebindex + +\end{document} diff --git a/noweb.sty b/noweb.sty new file mode 100644 index 0000000..1ea980b --- /dev/null +++ b/noweb.sty @@ -0,0 +1,989 @@ +% noweb.sty -- LaTeX support for noweb +% DON'T read or edit this file! Use ...noweb-source/tex/support.nw instead. +{\obeyspaces\AtBeginDocument{\global\let =\ }} % from texbook, p 381 +\def\nwopt@nomargintag{\let\nwmargintag=\@gobble} +\def\nwopt@margintag{% + \def\nwmargintag##1{\leavevmode\llap{##1\kern\nwmarginglue\kern\codemargin}}} +\def\nwopt@margintag{% + \def\nwmargintag##1{\leavevmode\kern-\codemargin\nwthemargintag{##1}\kern\codemargin}} +\def\nwthemargintag#1{\llap{#1\kern\nwmarginglue}} +\nwopt@margintag +\newdimen\nwmarginglue +\nwmarginglue=0.3in +\def\nwtagstyle{\footnotesize\Rm} +% make \hsize in code sufficient for 88 columns +\setbox0=\hbox{\tt m} +\newdimen\codehsize +\codehsize=91\wd0 % 88 columns wasn't enough; I don't know why +\newdimen\codemargin +\codemargin=0pt +\newdimen\nwdefspace +\nwdefspace=\codehsize +% need to use \textwidth in {\LaTeX} to handle styles with +% non-standard margins (David Bruce). Don't know why we sometimes +% wanted \hsize. 27 August 1997. +%% \advance\nwdefspace by -\hsize\relax +\ifx\textwidth\undefined + \advance\nwdefspace by -\hsize\relax +\else + \advance\nwdefspace by -\textwidth\relax +\fi +\chardef\other=12 +\def\setupcode{% + \chardef\\=`\\ + \chardef\{=`\{ + \chardef\}=`\} + \catcode`\$=\other + \catcode`\&=\other + \catcode`\#=\other + \catcode`\%=\other + \catcode`\~=\other + \catcode`\_=\other + \catcode`\^=\other + \catcode`\"=\other % fixes problem with german.sty + \obeyspaces\Tt +} +%\let\nwlbrace=\{ +%\let\nwrbrace=\} +\def\nwendquote{\relax\ifhmode\spacefactor=1000 \fi} +{\catcode`\^^M=\active % make CR an active character + \gdef\newlines{\catcode`\^^M=\active % make CR an active character + \def^^M{\par\startline}}% + \gdef\eatline#1^^M{\relax}% +} +%%% DON'T \gdef^^M{\par\startline}}% in case ^^M appears in a \write +\def\startline{\noindent\hskip\parindent\ignorespaces} +\def\nwnewline{\ifvmode\else\hfil\break\leavevmode\hbox{}\fi} +\def\setupmodname{% + \catcode`\$=3 + \catcode`\&=4 + \catcode`\#=6 + \catcode`\%=14 + \catcode`\~=13 + \catcode`\_=8 + \catcode`\^=7 + \catcode`\ =10 + \catcode`\^^M=5 + \let\nwlbrace\lbrace + \let\nwrbrace\rbrace + \let\{\nwlbrace + \let\}\nwrbrace + % bad news --- don't know what catcode to give " + \Rm} +\def\LA{\begingroup\maybehbox\bgroup\setupmodname\It$\langle$} +\def\RA{\/$\rangle$\egroup\endgroup} +\def\code{\leavevmode\begingroup\setupcode\newlines} +\def\edoc{\endgroup} +\let\maybehbox\relax +\newbox\equivbox +\setbox\equivbox=\hbox{$\equiv$} +\newbox\plusequivbox +\setbox\plusequivbox=\hbox{$\mathord{+}\mathord{\equiv}$} +% \moddef can't have an argument because there might be \code...\edoc +\def\moddef{\leavevmode\kern-\codemargin\LA} +\def\endmoddef{\RA\ifmmode\equiv\else\unhcopy\equivbox\fi + \nobreak\hfill\nobreak} +\def\plusendmoddef{\RA\ifmmode\mathord{+}\mathord{\equiv}\else\unhcopy\plusequivbox\fi + \nobreak\hfill\nobreak} +\def\chunklist{% +\errhelp{I changed \chunklist to \nowebchunks. +I'll try to avoid such incompatible changes in the future.}% +\errmessage{Use \string\nowebchunks\space instead of \string\chunklist}} +\def\nowebchunks{\message{}} +\def\nowebindex{\message{}} +% here is support for the new-style (capitalized) font-changing commands +% thanks to Dave Love +\ifx\documentstyle\undefined + \let\Rm=\rm \let\It=\it \let\Tt=\tt % plain +\else\ifx\selectfont\undefined + \let\Rm=\rm \let\It=\it \let\Tt=\tt % LaTeX OFSS +\else % LaTeX NFSS + \def\Rm{\reset@font\rm} + \def\It{\reset@font\it} + \def\Tt{\reset@font\tt} + \def\Bf{\reset@font\bf} +\fi\fi +\ifx\reset@font\undefined \let\reset@font=\relax \fi +\def\noweboptions#1{% + \def\@nwoptionlist{#1}% + \@for\@nwoption:=\@nwoptionlist\do{% + \@ifundefined{nwopt@\@nwoption}{% + \@latexerr{There is no such noweb option as '\@nwoption'}\@eha}{% + \csname nwopt@\@nwoption\endcsname}}} +\codemargin=10pt +\advance\codehsize by \codemargin % make room for indentation of code +\advance\nwdefspace by \codemargin % and fix adjustment for def/use +\def\setcodemargin#1{% + \advance\codehsize by -\codemargin % make room for indentation of code + \advance\nwdefspace by -\codemargin % and fix adjustment for def/use + \codemargin=#1 + \advance\codehsize by \codemargin % make room for indentation of code + \advance\nwdefspace by \codemargin % and fix adjustment for + % def/use +} +\def\nwopt@shift{% + \dimen@=-0.8in + \if@twoside % Values for two-sided printing: + \advance\evensidemargin by \dimen@ + \else % Values for one-sided printing: + \advance\evensidemargin by \dimen@ + \advance\oddsidemargin by \dimen@ + \fi +% \advance \marginparwidth -\dimen@ +} +\let\nwopt@noshift\@empty +\def\nwbegincode#1{% + \begingroup + \topsep \nwcodetopsep + \@beginparpenalty \@highpenalty + \@endparpenalty -\@highpenalty + \@begincode } +\def\nwendcode{\endtrivlist \endgroup \filbreak} % keeps code on 1 page + +\newenvironment{webcode}{% + \@begincode +}{% + \endtrivlist} +\def\@begincode{% + \trivlist \item[]% + \leftskip\@totalleftmargin \advance\leftskip\codemargin + \rightskip\hsize \advance\rightskip -\codehsize + \parskip\z@ \parindent\z@ \parfillskip\@flushglue + \linewidth\codehsize + \@@par + \def\par{\leavevmode\null \@@par \penalty\nwcodepenalty}% + \obeylines + \@noligs \ifx\verbatim@nolig@list\undefined\else + \let\do=\nw@makeother \verbatim@nolig@list \do@noligs\` + \fi + \setupcode \frenchspacing \@vobeyspaces + \nowebsize \setupcode + \let\maybehbox\mbox } + \newskip\nwcodetopsep \nwcodetopsep = 3pt plus 1.2pt minus 1pt + \let\nowebsize=\normalsize + \def\nwopt@tinycode{\let\nowebsize=\tiny} + \def\nwopt@footnotesizecode{\let\nowebsize=\footnotesize} + \def\nwopt@scriptsizecode{\let\nowebsize=\scriptsize} + \def\nwopt@smallcode{\let\nowebsize=\small} + \def\nwopt@normalsizecode{\let\nowebsize=\normalsize} + \def\nwopt@largecode{\let\nowebsize=\large} + \def\nwopt@Largecode{\let\nowebsize=\Large} + \def\nwopt@LARGEcode{\let\nowebsize=\LARGE} + \def\nwopt@hugecode{\let\nowebsize=\huge} + \def\nwopt@Hugecode{\let\nowebsize=\Huge} +\newcount\nwcodepenalty \nwcodepenalty=\@highpenalty +\def\nw@makeother#1{\catcode`#1=12 } +\def\nwbegindocs#1{\ifvmode\noindent\fi} +\let\nwenddocs=\relax +\let\nwdocspar=\filbreak +\def\@nwsemifilbreak#1{\vskip0pt plus#1\penalty-200\vskip0pt plus -#1} +\newdimen\nwbreakcodespace +\nwbreakcodespace=0.2in % by default, leave no more than this on a page +\def\nwopt@breakcode{% + \def\nwdocspar{\@nwsemifilbreak{0.2in}}% + \def\nwendcode{\endtrivlist\endgroup} % ditches filbreak +} +\raggedbottom +\def\code{\leavevmode\begingroup\setupcode\@vobeyspaces\obeylines} +\let\edoc=\endgroup +\newdimen\@original@textwidth +\def\ps@noweb{% + \@original@textwidth=\textwidth + \let\@mkboth\@gobbletwo + \def\@oddfoot{}\def\@evenfoot{}% No feet. + \if@twoside % If two-sided printing. + \def\@evenhead{\hbox to \@original@textwidth{% + \Rm \thepage\qquad{\Tt\leftmark}\hfil\today}}% Left heading. + \def\@oddhead{\hbox to \@original@textwidth{% + \Rm \today\hfil{\Tt\leftmark}\qquad\thepage}}% Right heading. + \else % If one-sided printing. + \def\@oddhead{\hbox to \@original@textwidth{% + \Rm \today\hfil{\Tt\leftmark}\qquad\thepage}}% Right heading. + \let\@evenhead\@oddhead + \fi + \let\chaptermark\@gobble + \let\sectionmark\@gobble + \let\subsectionmark\@gobble + \let\subsubsectionmark\@gobble + \let\paragraphmark\@gobble + \let\subparagraphmark\@gobble + \def\nwfilename{\begingroup\let\do\@makeother\dospecials + \catcode`\{=1 \catcode`\}=2 \nw@filename} + \def\nw@filename##1{\endgroup\markboth{##1}{##1}\let\nw@filename=\nw@laterfilename}% +} +\def\nw@laterfilename#1{\endgroup\clearpage \markboth{#1}{#1}} +\let\nwfilename=\@gobble +\def\nwcodecomment#1{\@@par\penalty\nwcodepenalty + \if@firstnwcodecomment + \vskip\nwcodecommentsep\penalty\nwcodepenalty\@firstnwcodecommentfalse + \fi% + \hspace{-\codemargin}{% + \rightskip=0pt plus1in + \interlinepenalty\nwcodepenalty + \let\\\relax\footnotesize\Rm #1\@@par\penalty\nwcodepenalty}} +\def\@nwalsodefined#1{\nwcodecomment{\@nwlangdepdef\ \nwpageprep\ \@pagesl{#1}.}} +\def\@nwused#1{\nwcodecomment{\@nwlangdepcud\ \nwpageprep\ \@pagesl{#1}.}} +\def\@nwnotused#1{\nwcodecomment{\@nwlangdeprtc.}} +\def\nwoutput#1{\nwcodecomment{\@nwlangdepcwf\ {\Tt \@stripstar#1*\stripped}.}} +\def\@stripstar#1*#2\stripped{#1} +\newcommand{\nwprevdefptr}[1]{% + \mbox{$\mathord{\triangleleft}\,\mathord{\mbox{\subpageref{#1}}}$}} +\newcommand{\nwnextdefptr}[1]{% + \mbox{$\mathord{\mbox{\subpageref{#1}}}\,\mathord{\triangleright}$}} + +\newcommand{\@nwprevnextdefs}[2]{% + {\nwtagstyle + \ifx\relax#1\else ~~\nwprevdefptr{#1}\fi + \ifx\relax#2\else ~~\nwnextdefptr{#2}\fi}} +\newcommand{\@nwusesondefline}[1]{{\nwtagstyle~~(\@pagenumsl{#1})}} +\newcommand{\@nwstartdeflinemarkup}{\nobreak\hskip 1.5em plus 1fill\nobreak} +\newcommand{\@nwenddeflinemarkup}{\nobreak\hskip \nwdefspace minus\nwdefspace\nobreak} +\def\nwopt@longxref{% + \let\nwalsodefined\@nwalsodefined + \let\nwused\@nwused + \let\nwnotused\@nwnotused + \let\nwprevnextdefs\@gobbletwo + \let\nwusesondefline\@gobble + \let\nwstartdeflinemarkup\relax + \let\nwenddeflinemarkup\relax +} +\def\nwopt@shortxref{% + \let\nwalsodefined\@gobble + \let\nwused\@gobble + \let\nwnotused\@gobble + \let\nwprevnextdefs\@nwprevnextdefs + \let\nwusesondefline\@nwusesondefline + \let\nwstartdeflinemarkup\@nwstartdeflinemarkup + \let\nwenddeflinemarkup\@nwenddeflinemarkup +} +\def\nwopt@noxref{% + \let\nwalsodefined\@gobble + \let\nwused\@gobble + \let\nwnotused\@gobble + \let\nwprevnextdefs\@gobbletwo + \let\nwusesondefline\@gobble + \let\nwstartdeflinemarkup\relax + \let\nwenddeflinemarkup\relax +} +\nwopt@shortxref % to hell with backward compatibility! +\newskip\nwcodecommentsep \nwcodecommentsep=3pt plus 1pt minus 1pt +\newif\if@firstnwcodecomment\@firstnwcodecommenttrue +\newcount\@nwlopage\newcount\@nwhipage % range lo..hi-1 +\newcount\@nwlosub % subpage of lo +\newcount\@nwhisub % subpage of hi +\def\@nwfirstpage#1#2#3{% subpage page xref-tag + \@nwlopage=#2 \@nwlosub=#1 + \def\@nwloxreftag{#3}% + \advance\@nwpagecount by \@ne + \@nwhipage=\@nwlopage\advance\@nwhipage by \@ne } +\def\@nwnextpage#1#2#3{% subpage page xref-tag + \ifnum\@nwhipage=#2 + \advance\@nwhipage by \@ne + \advance\@nwpagecount by \@ne + \@nwhisub=#1 + \def\@nwhixreftag{#3}\else + \ifnum#2<\@nwlopage \advance\@nwhipage by \m@ne + \ifnum\@nwhipage=\@nwlopage + \edef\@tempa{\noexpand\noexpand\noexpand\\% + {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% + {\@nwloxreftag}}}% + \else + \count@=\@nwhipage \advance\count@ by \m@ne + \ifnum\count@=\@nwlopage % consecutive pages + \edef\@tempa{\noexpand\noexpand\noexpand\\% + {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% + {\@nwloxreftag}}% + \noexpand\noexpand\noexpand\\% + {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} + {\@nwhixreftag}}}% + \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else + \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 + \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else + \count@=\@nwlopage \divide\count@ by 100 + \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 + \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi + \multiply\@nwpagetemp by 100 + \advance \@nwhipage by -\@nwpagetemp + \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% + \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% + \fi + \fi + \fi% + \fi + \fi% + \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\@nwfirstpage{#1}{#2}{#3}\else + \ifnum#2>\@nwhipage \advance\@nwhipage by \m@ne + \ifnum\@nwhipage=\@nwlopage + \edef\@tempa{\noexpand\noexpand\noexpand\\% + {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% + {\@nwloxreftag}}}% + \else + \count@=\@nwhipage \advance\count@ by \m@ne + \ifnum\count@=\@nwlopage % consecutive pages + \edef\@tempa{\noexpand\noexpand\noexpand\\% + {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% + {\@nwloxreftag}}% + \noexpand\noexpand\noexpand\\% + {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} + {\@nwhixreftag}}}% + \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else + \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 + \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else + \count@=\@nwlopage \divide\count@ by 100 + \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 + \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi + \multiply\@nwpagetemp by 100 + \advance \@nwhipage by -\@nwpagetemp + \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% + \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% + \fi + \fi + \fi% + \fi + \fi% + \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\@nwfirstpage{#1}{#2}{#3}\else + \@nwlosub=0 \@nwhisub=0 + \fi\fi\fi + } +\newcount\@nwpagetemp +\newcount\@nwpagecount +\def\@nwfirstpagel#1{% label + \@ifundefined{r@#1}{\@warning{Reference `#1' on page \thepage \space undefined}% + \nwix@cons\nw@pages{\\{\bf ??}}}{% + \edef\@tempa{\noexpand\@nwfirstpage\subpagepair{#1}{#1}}\@tempa}} +\def\@nwnextpagel#1{% label + \@ifundefined{r@#1}{\@warning{Reference `#1' on page \thepage \space undefined}% + \nwix@cons\nw@pages{\\{\bf ??}}}{% + \edef\@tempa{\noexpand\@nwnextpage\subpagepair{#1}{#1}}\@tempa}} +\def\@pagesl#1{% list of labels + \gdef\nw@pages{}\@nwpagecount=0 + \def\\##1{\@nwfirstpagel{##1}\let\\=\@nwnextpagel}#1% + \advance\@nwhipage by \m@ne + \ifnum\@nwhipage=\@nwlopage + \edef\@tempa{\noexpand\noexpand\noexpand\\% + {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% + {\@nwloxreftag}}}% + \else + \count@=\@nwhipage \advance\count@ by \m@ne + \ifnum\count@=\@nwlopage % consecutive pages + \edef\@tempa{\noexpand\noexpand\noexpand\\% + {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% + {\@nwloxreftag}}% + \noexpand\noexpand\noexpand\\% + {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} + {\@nwhixreftag}}}% + \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else + \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 + \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else + \count@=\@nwlopage \divide\count@ by 100 + \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 + \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi + \multiply\@nwpagetemp by 100 + \advance \@nwhipage by -\@nwpagetemp + \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% + \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% + \fi + \fi + \fi% + \fi + \fi% + \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\def\\##1{\@nwhyperpagenum##1}% + \ifnum\@nwpagecount=1 \nwpageword \else \nwpagesword\fi~\commafy{\nw@pages}} +\def\@nwhyperpagenum#1#2{\nwhyperreference{#2}{#1}} + +\def\@pagenumsl#1{% list of labels -- doesn't include word `pages', commas, or `and' + \gdef\nw@pages{}\@nwpagecount=0 + \def\\##1{\@nwfirstpagel{##1}\let\\=\@nwnextpagel}#1% + \advance\@nwhipage by \m@ne + \ifnum\@nwhipage=\@nwlopage + \edef\@tempa{\noexpand\noexpand\noexpand\\% + {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% + {\@nwloxreftag}}}% + \else + \count@=\@nwhipage \advance\count@ by \m@ne + \ifnum\count@=\@nwlopage % consecutive pages + \edef\@tempa{\noexpand\noexpand\noexpand\\% + {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% + {\@nwloxreftag}}% + \noexpand\noexpand\noexpand\\% + {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} + {\@nwhixreftag}}}% + \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else + \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 + \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else + \count@=\@nwlopage \divide\count@ by 100 + \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 + \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi + \multiply\@nwpagetemp by 100 + \advance \@nwhipage by -\@nwpagetemp + \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% + \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% + \fi + \fi + \fi% + \fi + \fi% + \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa% + \def\\##1{\@nwhyperpagenum##1\let\\=\@nwpagenumslrest}\nw@pages} +\def\@nwpagenumslrest#1{~\@nwhyperpagenum#1} +\def\subpages#1{% list of {{subpage}{page}} + \gdef\nw@pages{}\@nwpagecount=0 + \def\\##1{\edef\@tempa{\noexpand\@nwfirstpage##1{}}\@tempa + \def\\####1{\edef\@tempa{\noexpand\@nwnextpage####1}\@tempa}}#1% + \advance\@nwhipage by \m@ne + \ifnum\@nwhipage=\@nwlopage + \edef\@tempa{\noexpand\noexpand\noexpand\\% + {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% + {\@nwloxreftag}}}% + \else + \count@=\@nwhipage \advance\count@ by \m@ne + \ifnum\count@=\@nwlopage % consecutive pages + \edef\@tempa{\noexpand\noexpand\noexpand\\% + {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% + {\@nwloxreftag}}% + \noexpand\noexpand\noexpand\\% + {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} + {\@nwhixreftag}}}% + \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else + \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 + \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else + \count@=\@nwlopage \divide\count@ by 100 + \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 + \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi + \multiply\@nwpagetemp by 100 + \advance \@nwhipage by -\@nwpagetemp + \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% + \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% + \fi + \fi + \fi% + \fi + \fi% + \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa\def\\##1{\@firstoftwo##1}% + \ifnum\@nwpagecount=1 \nwpageword \else \nwpagesword\fi~\commafy{\nw@pages}} +\def\@nwaddrange{\advance\@nwhipage by \m@ne + \ifnum\@nwhipage=\@nwlopage + \edef\@tempa{\noexpand\noexpand\noexpand\\% + {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% + {\@nwloxreftag}}}% + \else + \count@=\@nwhipage \advance\count@ by \m@ne + \ifnum\count@=\@nwlopage % consecutive pages + \edef\@tempa{\noexpand\noexpand\noexpand\\% + {{\nwthepagenum{\number\@nwlosub}{\number\@nwlopage}}% + {\@nwloxreftag}}% + \noexpand\noexpand\noexpand\\% + {{\nwthepagenum{\number\@nwhisub}{\number\@nwhipage}} + {\@nwhixreftag}}}% + \else \ifnum\@nwlopage<110 \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else + \count@=\@nwlopage \divide\count@ by 100 \multiply\count@ by 100 + \ifnum\count@=\@nwlopage \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}\else + \count@=\@nwlopage \divide\count@ by 100 + \@nwpagetemp=\@nwhipage \divide\@nwpagetemp by 100 + \ifnum\count@=\@nwpagetemp % lo--least 2 digits of hi + \multiply\@nwpagetemp by 100 + \advance \@nwhipage by -\@nwpagetemp + \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% + \else \edef\@tempa{\noexpand\noexpand\noexpand\\{{\number\@nwlopage--\number\@nwhipage}{}}}% + \fi + \fi + \fi% + \fi + \fi% + \edef\@tempa{\noexpand\nwix@cons\noexpand\nw@pages{\@tempa}}\@tempa} +\def\nwpageword{\@nwlangdepchk} % chunk, was page +\def\nwpagesword{\@nwlangdepchks} % chunk, was page +\def\nwpageprep{\@nwlangdepin} % in, was on +\newcommand\nw@genericref[2]{% what to do, name of ref + \expandafter\nw@g@nericref\csname r@#2\endcsname#1{#2}} +\newcommand\nw@g@nericref[3]{% control sequence, what to do, name + \ifx#1\relax + \ref{#3}% trigger the standard `undefined ref' mechanisms + \else + \expandafter#2#1.\\% + \fi} +\def\nw@selectone#1#2#3\\{#1} +\def\nw@selecttwo#1#2#3\\{#2} +\def\nw@selectonetwo#1#2#3\\{{#1}{#2}} +\newcommand{\subpageref}[1]{% + \nwhyperreference{#1}{\nw@genericref\@subpageref{#1}}} +\def\@subpageref#1#2#3\\{% + \@ifundefined{2on#2}{#2}{\nwthepagenum{#1}{#2}}} +\newcommand{\subpagepair}[1]{% % produces {subpage}{page} + \@ifundefined{r@#1}% + {{0}{0}}% + {\nw@genericref\@subpagepair{#1}}} +\def\@subpagepair#1#2#3\\{% + \@ifundefined{2on#2}{{0}{#2}}{{#1}{#2}}} +\newcommand{\sublabel}[1]{% + \leavevmode % needed to make \@bsphack work + \@bsphack + \nwblindhyperanchor{#1}% + \if@filesw {\let\thepage\relax + \def\protect{\noexpand\noexpand\noexpand}% + \edef\@tempa{\write\@auxout{\string + \newsublabel{#1}{{}{\thepage}}}}% + \expandafter}\@tempa + \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} +\newcommand{\nosublabel}[1]{% + \@bsphack\if@filesw {\let\thepage\relax + \def\protect{\noexpand\noexpand\noexpand}% + \edef\@tempa{\write\@auxout{\string + \newlabel{#1}{{0}{\thepage}}}}% + \expandafter}\@tempa + \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} +\newcommand\newsublabel{% + \nw@settrailers + \global\let\newsublabel\@newsublabel + \@newsublabel} +\newcommand{\@newsublabel}[2]{% + \edef\this@page{\@cdr#2\@nil}% + \ifx\this@page\last@page\else + \sub@page=\z@ + \fi + \edef\last@page{\this@page} + \advance\sub@page by \@ne + \ifnum\sub@page=\tw@ + \global\@namedef{2on\this@page}{}% + \fi + \pendingsublabel{#1}% + \edef\@tempa##1{\noexpand\newlabel{##1}% + {{\number\sub@page}{\this@page}\nw@labeltrailers}}% + \pending@sublabels + \def\pending@sublabels{}} +\newcommand\nw@settrailers{% -- won't work on first run + \@ifpackageloaded{nameref}% + {\gdef\nw@labeltrailers{{}{}{}}}% + {\gdef\nw@labeltrailers{}}} +\renewcommand\nw@settrailers{% + \@ifundefined{@secondoffive}% + {\gdef\nw@labeltrailers{}}% + {\gdef\nw@labeltrailers{{}{}{}}}} +\newcommand{\nextchunklabel}[1]{% + \nwblindhyperanchor{#1}% % looks slightly bogus --- nr + \@bsphack\if@filesw {\let\thepage\relax + \edef\@tempa{\write\@auxout{\string\pendingsublabel{#1}}}% + \expandafter}\@tempa + \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} +\newcommand\pendingsublabel[1]{% + \def\@tempa{\noexpand\@tempa}% + \edef\pending@sublabels{\noexpand\@tempa{#1}\pending@sublabels}} +\def\pending@sublabels{} +\def\last@page{\relax} +\newcount\sub@page +\def\@alphasubpagenum#1#2{#2\ifnum#1=0 \else\@alph{#1}\fi} +\def\@nosubpagenum#1#2{#2} +\def\@numsubpagenum#1#2{#2\ifnum#1=0 \else.\@arabic{#1}\fi} +\def\nwopt@nosubpage{\let\nwthepagenum=\@nosubpagenum\nwopt@nomargintag} +\def\nwopt@numsubpage{\let\nwthepagenum=\@numsubpagenum} +\def\nwopt@alphasubpage{\let\nwthepagenum=\@alphasubpagenum} +\nwopt@alphasubpage +\newcount\@nwalph@n +\let\@nwalph@d\@tempcnta +\let\@nwalph@bound\@tempcntb +\def\@nwlongalph#1{{% + \@nwalph@n=#1\advance\@nwalph@n by-1 + \@nwalph@bound=26 + \loop\ifnum\@nwalph@n<\@nwalph@bound\else + \advance\@nwalph@n by -\@nwalph@bound + \multiply\@nwalph@bound by 26 + \repeat + \loop\ifnum\@nwalph@bound>1 + \divide\@nwalph@bound by 26 + \@nwalph@d=\@nwalph@n\divide\@nwalph@d by \@nwalph@bound + % d := d * bound ; n -:= d; d := d / bound --- saves a temporary + \multiply\@nwalph@d by \@nwalph@bound + \advance\@nwalph@n by -\@nwalph@d + \divide\@nwalph@d by \@nwalph@bound + \advance\@nwalph@d by 1 \@alph{\@nwalph@d}% + \repeat +}} +\newcount\nw@chunkcount +\nw@chunkcount=\@ne +\newcommand{\weblabel}[1]{% + \@bsphack + \nwblindhyperanchor{#1}% + \if@filesw {\let\thepage\relax + \def\protect{\noexpand\noexpand\noexpand}% + \edef\@tempa{\write\@auxout{\string + \newsublabel{#1}{{}{\number\nw@chunkcount}}}}% + \expandafter}\@tempa + \global\advance\nw@chunkcount by \@ne + \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} +\def\nwopt@webnumbering{% + \let\sublabel=\weblabel + \def\nwpageword{chunk}\def\nwpagesword{chunks}% + \def\nwpageprep{in}} +% \nwindexdefn{printable name}{identifying label}{label of chunk} +% \nwindexuse{printable name}{identifying label}{label of chunk} + +\def\nwindexdefn#1#2#3{\@auxix{\protect\nwixd}{#2}{#3}} +\def\nwindexuse#1#2#3{\@auxix{\protect\nwixu}{#2}{#3}} + +\def\@auxix#1#2#3{% {marker}{id label}{subpage label} + \@bsphack\if@filesw {\let\nwixd\relax\let\nwixu\relax + \def\protect{\noexpand\noexpand\noexpand}% + \edef\@tempa{\write\@auxout{\string\nwixadd{#1}{#2}{#3}}}% + \expandafter}\@tempa + \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} +% \nwixadd{marker}{idlabel}{subpage label} +\def\nwixadd#1#2#3{% + \@ifundefined{nwixl@#2}% + {\global\@namedef{nwixl@#2}{#1{#3}}}% + {\expandafter\nwix@cons\csname nwixl@#2\endcsname{#1{#3}}}} +\def\@nwsubscriptident#1#2{\mbox{$\mbox{#1}_{\mathrm{\subpageref{#2}}}$}} +\def\@nwnosubscriptident#1#2{#1} +\def\@nwhyperident#1#2{\leavevmode\nwhyperreference{#2}{#1}} +\def\nwopt@subscriptidents{% + \let\nwlinkedidentq\@nwsubscriptident + \let\nwlinkedidentc\@nwsubscriptident +} +\def\nwopt@nosubscriptidents{% + \let\nwlinkedidentq\@nwnosubscriptident + \let\nwlinkedidentc\@nwnosubscriptident +} +\def\nwopt@hyperidents{% + \let\nwlinkedidentq\@nwhyperident + \let\nwlinkedidentc\@nwhyperident +} +\def\nwopt@nohyperidents{% + \let\nwlinkedidentq\@nwnosubscriptident + \let\nwlinkedidentc\@nwnosubscriptident +} +\def\nwopt@subscriptquotedidents{% + \let\nwlinkedidentq\@nwsubscriptident +} +\def\nwopt@nosubscriptquotedidents{% + \let\nwlinkedidentq\@nwnosubscriptident +} +\def\nwopt@hyperquotedidents{% + \let\nwlinkedidentq\@nwhyperident +} +\def\nwopt@nohyperquotedidents{% + \let\nwlinkedidentq\@nwnosubscriptident +} +\nwopt@hyperidents +\newcount\@commacount +\def\commafy#1{% + {\nwix@listcount{#1}\@commacount=\nwix@counter + \let\@comma@each=\\% + \ifcase\@commacount\let\\=\@comma@each\or\let\\=\@comma@each\or + \def\\{\def\\{ \@nwlangdepand\ \@comma@each}\@comma@each}\else + \def\\{\def\\{, % + \advance\@commacount by \m@ne + \ifnum\@commacount=1 \@nwlangdepand~\fi\@comma@each}\@comma@each}\fi + #1}} +\def\nwix@cons#1#2{% {list}{\marker{element}} + {\toks0=\expandafter{#1}\def\@tempa{#2}\toks2=\expandafter{\@tempa}% + \xdef#1{\the\toks0 \the\toks2 }}} +\def\nwix@uses#1{% {label} + \def\nwixu{\\}\let\nwixd\@gobble\@nameuse{nwixl@#1}} +\def\nwix@defs#1{% {label} + \def\nwixd{\\}\let\nwixu\@gobble\@nameuse{nwixl@#1}} +\newcount\nwix@counter +\def\nwix@listcount#1{% {list with \\} + {\count@=0 + \def\\##1{\advance\count@ by \@ne }% + #1\global\nwix@counter=\count@ }} +\def\nwix@usecount#1{\nwix@listcount{\nwix@uses{#1}}} +\def\nwix@defcount#1{\nwix@listcount{\nwix@defs{#1}}} +\def\nwix@id@defs#1{% index pair + {{\Tt \@car#1\@nil}% + \def\\##1{\nwix@defs@space\subpageref{##1}}\nwix@defs{\@cdr#1\@nil}}} + % useful above to change ~ into something that can break +% this option is undocumented because I think breakdefs is always right +\def\nwopt@breakdefs{\def\nwix@defs@space{\penalty200\ }} +\def\nwopt@nobreakdefs{\def\nwix@defs@space{~}} % old code +\nwopt@breakdefs +\def\nwidentuses#1{% list of index pairs + \nwcodecomment{\@nwlangdepuss\ \let\\=\nwix@id@defs\commafy{#1}.}} +\def\nwix@totaluses#1{% list of index pairs + {\count@=0 + \def\\##1{\nwix@usecount{\@cdr##1\@nil}\advance\count@ by\nwix@counter}% + #1\global\nwix@counter\count@ }} +\def\nwix@id@uses#1#2{% {ident}{label} + \nwix@usecount{#2}\ifnum\nwix@counter>0 + {\advance\leftskip by \codemargin + \nwcodecomment{{\Tt #1}, \@nwlangdepusd\ \nwpageprep\ \@pagesl{\nwix@uses{#2}}.}}% + \else + \ifnw@hideunuseddefs\else + {\advance\leftskip by \codemargin \nwcodecomment{{\Tt #1}, \@nwlangdepnvu.}}% + \fi + \fi} +\def\nwidentdefs#1{% list of index pairs + \ifnw@hideunuseddefs\nwix@totaluses{#1}\else\nwix@listcount{#1}\fi + \ifnum\nwix@counter>0 + \nwcodecomment{\@nwlangdepdfs:}% + {\def\\##1{\nwix@id@uses ##1}#1}% + \fi} +\newif\ifnw@hideunuseddefs\nw@hideunuseddefsfalse +\def\nwopt@hideunuseddefs{\nw@hideunuseddefstrue} +\def\nwopt@noidentxref{% + \let\nwidentdefs\@gobble + \let\nwidentuses\@gobble} +\def\nw@underlinedefs{% {list with \nwixd, \nwixu} + \let\\=\relax\def\nw@comma{, } + \def\nwixd##1{\\\underline{\subpageref{##1}}\let\\\nw@comma}% + \def\nwixu##1{\\\subpageref{##1}\let\\\nw@comma}} + +\def\nw@indexline#1#2{% + {\indent {\Tt #1}: \nw@underlinedefs\@nameuse{nwixl@#2}\par}} + +\newenvironment{thenowebindex}{\parindent=-10pt \parskip=\z@ + \advance\leftskip by 10pt + \advance\rightskip by 0pt plus1in\par\@afterindenttrue + \def\\##1{\nw@indexline##1}}{} +\def\nowebindex{% + \@ifundefined{nwixs@i}% + {\@warning{The \string\nowebindex\space is empty}}% + {\begin{thenowebindex}\@nameuse{nwixs@i}\end{thenowebindex}}} +\def\nowebindex@external{% + {\let\nwixadds@c=\@gobble + \def\nwixadds@i##1{\nw@indexline##1}% + \def\nwixaddsx##1##2{\@nameuse{nwixadds@##1}{##2}}% + \begin{thenowebindex}\@input{\jobname.nwi}\end{thenowebindex}}} +\def\nwixlogsorted#1#2{% list data + \@bsphack\if@filesw + \toks0={#2}\immediate\write\@auxout{\string\nwixadds{#1}{\the\toks0}} + \if@nobreak \ifvmode\nobreak\fi\fi\fi\@esphack} +\def\nwixadds#1#2{% + \@ifundefined{nwixs@#1}% + {\global\@namedef{nwixs@#1}{\\{#2}}}% + {\expandafter\nwix@cons\csname nwixs@#1\endcsname{\\{#2}}}} +\let\nwixaddsx=\@gobbletwo +\def\nwopt@externalindex{% + \ifx\nwixadds\@gobbletwo % already called + \else + \let\nwixaddsx=\nwixadds \let\nwixadds=\@gobbletwo + \let\nowebindex=\nowebindex@external + \let\nowebchunks=\nowebchunks@external + \fi} +\def\nowebchunks{% + \@ifundefined{nwixs@c}% + {\@warning{The are no \string\nowebchunks}}% + {\begin{thenowebchunks}\@nameuse{nwixs@c}\end{thenowebchunks}}} +\def\nowebchunks@external{% + {\let\nwixadds@i=\@gobble + \def\nwixadds@c##1{\nw@onechunk##1}% + \def\nwixaddsx##1##2{\@nameuse{nwixadds@##1}{##2}}% + \begin{thenowebchunks}\@input{\jobname.nwi}\end{thenowebchunks}}} + \@namedef{r@nw@notdef}{{0}{(\@nwlangdepnvd)}} +\def\nw@chunkunderlinedefs{% {list of labels with \nwixd, \nwixu} + \let\\=\relax\def\nw@comma{, } + \def\nwixd##1{\\\underline{\subpageref{##1}}\let\\\nw@comma}% + \def\nwixu##1{\\\subpageref{##1}\let\\\nw@comma}} +\def\nw@onechunk#1#2#3{% {name}{label of first definition}{list with \nwixd, \nwixu} + \@ifundefined{r@#2}{}{% + \indent\LA #1~{\nwtagstyle\subpageref{#2}}\RA + \if@nwlongchunks{~\nw@chunkunderlinedefs#3}\fi\par}} +\newenvironment{thenowebchunks}{\vskip3pt + \parskip=\z@\parindent=-10pt \advance\leftskip by 10pt + \advance\rightskip by 0pt plus10pt \@afterindenttrue + \def\\##1{\nw@onechunk##1}}{} +\newif\if@nwlongchunks +\@nwlongchunksfalse +\let\nwopt@longchunks\@nwlongchunkstrue +\newcommand\@nw@hyper@ref{\hyperreference} % naras +\newcommand\@nw@hyper@anc{\blindhyperanchor} % naras +\newcommand\@nw@hyperref@ref[2]{\hyperlink{noweb.#1}{#2}} % nr +\newcommand\@nw@hyperref@anc[1]{\hypertarget{noweb.#1}{\relax}} % nr +%%\renewcommand\@nw@hyperref@ref[2]{{#2}} % nr +%%\renewcommand\@nw@hyperref@anc[1]{} % nr +\newcommand\nwhyperreference{% + \@ifundefined{hyperlink} + {\@ifundefined{hyperreference} + {\global\let\nwhyperreference\@gobble} + {\global\let\nwhyperreference\@nw@hyper@ref}} + {\global\let\nwhyperreference\@nw@hyperref@ref}% + \nwhyperreference +} + +\newcommand\nwblindhyperanchor{% + \@ifundefined{hyperlink} + {\@ifundefined{hyperreference} + {\global\let\nwblindhyperanchor\@gobble} + {\global\let\nwblindhyperanchor\@nw@hyper@anc}} + {\global\let\nwblindhyperanchor\@nw@hyperref@anc}% + \nwblindhyperanchor +} +\newcommand\nwanchorto{% + \begingroup\let\do\@makeother\dospecials + \catcode`\{=1 \catcode`\}=2 \nw@anchorto} +\newcommand\nw@anchorto[1]{\endgroup\def\nw@next{#1}\nw@anchortofin} +\newcommand\nw@anchortofin[1]{#1\footnote{See URL \texttt{\nw@next}.}} +\let\nwanchorname\@gobble +\newif\ifhtml +\htmlfalse +\let\nwixident=\relax +\def\nwbackslash{\char92} +\def\nwlbrace{\char123} +\def\nwrbrace{\char125} +\def\nwopt@english{% + \def\@nwlangdepdef{This definition is continued}% + \def\@nwlangdepcud{This code is used}% + \def\@nwlangdeprtc{Root chunk (not used in this document)}% + \def\@nwlangdepcwf{This code is written to file}% + \def\@nwlangdepchk{chunk}% + \def\@nwlangdepchks{chunks}% + \def\@nwlangdepin{in}% + \def\@nwlangdepand{and}% + \def\@nwlangdepuss{Uses}% + \def\@nwlangdepusd{used}% + \def\@nwlangdepnvu{never used}% + \def\@nwlangdepdfs{Defines}% + \def\@nwlangdepnvd{never defined}% +} +\let\nwopt@american\nwopt@english +\def\nwopt@portuges{% + \def\@nwlangdepdef{Defini\c{c}\~ao continuada em}% + % This definition is continued + \def\@nwlangdepcud{C\'odigo usado em}% + % This code is used + \def\@nwlangdeprtc{Fragmento de topo (sem uso no documento)}% + % Root chunk (not used in this document) + \def\@nwlangdepcwf{Este c\'odigo foi escrito no ficheiro}% + % This code is written to file + \def\@nwlangdepchk{fragmento}% + % chunk + \def\@nwlangdepchks{fragmentos}% + % chunks + \def\@nwlangdepin{no(s)}% + % in + \def\@nwlangdepand{e}% + % and + \def\@nwlangdepuss{Usa}% + % Uses + \def\@nwlangdepusd{usado}% + % used + \def\@nwlangdepnvu{nunca usado}% + % never used + \def\@nwlangdepdfs{Define}% + % Defines + \def\@nwlangdepnvd{nunca definido}% + % never defined +} +\def\nwopt@brazil{% + \def\@nwlangdepdef{Defini\c{c}\~{a}o continua}% + % This definition is continued + \def\@nwlangdepcud{C\'odigo usado}% + % This code is used + \def\@nwlangdeprtc{Trecho raiz, isto é, este trecho come\c{c}a aqui}% + % Root chunk (not used in this document) + \def\@nwlangdepcwf{C\'odigo escrito no arquivo}% + % This code is written to file + \def\@nwlangdepchk{trecho}% + % chunk + \def\@nwlangdepchks{trechos}% + % chunks + \def\@nwlangdepin{@}% + % in + \def\@nwlangdepand{e}% + % and + \def\@nwlangdepuss{Usa}% + % Uses + \def\@nwlangdepusd{usado}% + % used + \def\@nwlangdepnvu{nunca usado}% + % never used + \def\@nwlangdepdfs{Define}% + % Defines + \def\@nwlangdepnvd{nunca definido}% + % never defined +} +\def\nwopt@frenchb{% + \def\@nwlangdepdef{Suite de la d\'efinition}% + % This definition is continued + \def\@nwlangdepcud{Ce code est employ\'e}% + % This code is used + \def\@nwlangdeprtc{Morceau racine (pas employ\'e dans ce document)}% + % Root chunk (not used in this document) + \def\@nwlangdepcwf{Ce code est \'ecrit dans le fichier}% + % This code is written to file + \def\@nwlangdepchk{le morceau}% + % chunk + \def\@nwlangdepchks{les morceaux}% + % chunks + \def\@nwlangdepin{dans}% + % in + \def\@nwlangdepand{et}% + % and + \def\@nwlangdepuss{Utilise}% + % Uses + \def\@nwlangdepusd{utilis\'{e}}% + % used + \def\@nwlangdepnvu{jamais employ\'{e}}% + % never used + \def\@nwlangdepdfs{D\'{e}finit}% + % Defines + % Cannot use the accent here: \def\@nwlangdepnvd{jamais d\'{e}fini}% + \def\@nwlangdepnvd{jamais defini}% + % never defined +} +\let\nwopt@french\nwopt@frenchb +\def\nwopt@german{% + \def\@nwlangdepdef{Diese Definition wird fortgesetzt}% + % This definition is continued + \def\@nwlangdepcud{Dieser Code wird benutzt}% + % This code is used + \def\@nwlangdeprtc{Hauptteil (nicht in diesem Dokument benutzt)}% + % Root chunk (not used in this document) + %\def\@nwlangdepcwf{Dieser Code schreibt man zum File}% + \def\@nwlangdepcwf{Dieser Code geht in Datei}% + % This code is written to file + \def\@nwlangdepchk{dem Teil}% + % chunk + %\def\@nwlangdepchks{Teils}% + \def\@nwlangdepchks{den Teilen}% + % chunks + \def\@nwlangdepin{in}% + % in + \def\@nwlangdepand{und}% + % and + \def\@nwlangdepuss{Benutzt}% + % Uses + \def\@nwlangdepusd{benutzt}% + % used + \def\@nwlangdepnvu{nicht benutzt}% + % never used + \def\@nwlangdepdfs{Definiert}% + % Defines + \def\@nwlangdepnvd{nicht definiert}% + % never defined +} +\def\nwopt@german{% + \def\@nwlangdepdef{Diese Definition wird fortgesetzt}% + % This definition is continued + \def\@nwlangdepcud{Dieser Code wird benutzt}% + % This code is used + \def\@nwlangdeprtc{Hauptteil (nicht in diesem Dokument benutzt)}% + % Root chunk (not used in this document) + \def\@nwlangdepcwf{Dieser Code schreibt man zum File}% + % This code is written to file + \def\@nwlangdepchk{Teil}% + % chunk + \def\@nwlangdepchks{Teils}% + % chunks + \def\@nwlangdepin{im}% + % in + \def\@nwlangdepand{und}% + % and + \def\@nwlangdepuss{Benutzt}% + % Uses + \def\@nwlangdepusd{benutzt}% + % used + \def\@nwlangdepnvu{nicht benutzt}% + % never used + \def\@nwlangdepdfs{Definiert}% + % Defines + \def\@nwlangdepnvd{nicht definiert}% + % never defined +} +\let\nwopt@ngerman\nwopt@german +\ifx\languagename\undefined % default is English + \noweboptions{english} +\else + \@ifundefined{nwopt@\languagename} + {\noweboptions{english}} + {\expandafter\noweboptions\expandafter{\languagename}} +\fi +\let\obeyedspace\@xobeysp diff --git a/peat b/peat new file mode 100644 index 0000000..5078c80 --- /dev/null +++ b/peat @@ -0,0 +1,224 @@ +#!/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() +