loop/srv
1
0
Fork 0
Code Issues Pull requests Activity

Identifies each binary with a version tag.

Browse source 
It also includes scripts for formating Lisp code for people who will
read Lisp code directly.  It doesn't cost us much to organize the Lisp
output a bit.  In a similar spirit, I'm not including NOWEB as part of
the build process.  (Most users will not have NOWEB around to use it.)
So while the Makefile is pretty short because there's little to do,
Anyfile is the ANYWEB makefile.  ANYWEB is my modified, personal
version of NOWEB for Windows.  (The way I use this second makefile is
to make a shell alias called /amake/ that automatically invokes ``make
-f Anyfile'' for me.)
This commit is contained in:
Circling Skies 2024-12-17 15:21:47 -03:00
parent de6c586755
commit 77c411756d
8 changed files with 370 additions and 134 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

67
Anyfile Normal file
View file

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

74
README
View file

@ -6,7 +6,7 @@ LOOP is an NNTP server written in Common Lisp.
We assume
- you run SBCL, Quicklisp and git installed
- you have SBCL, Quicklisp and git installed
- you know how to use a TCP server such as
https://cr.yp.to/ucspi-tcp.html
- you know how to manage a daemon with a package such as
@ -26,37 +26,13 @@ and say
$ echo /path/to/loop/home > conf-home
$ make install
(*) Systems with no installation issues
We installed LOOP just fine on
FreeBSD 14.1, 14.2 with SBCL 2.4.9.
Debian GNU/Linux 8.11 codename jessie with SBCL 1.2.4.debian.
(*) Systems with installation issues
We installed LOOP on Ubuntu 24.04 (24.01.1 LTS) codename noble with
SBCL 2.2.9.debian. We found that CLSQL could not load the shared
object libsqlite3.so because ``apt install libsqlite3'' installs the
library at
/usr/lib/x86_64-linux-gnu/libsqlite3.so.0.8.6
with a symbolic link to libsqlite3.so.0, but not to libsqlite3.so.
SBCL is trying to load libsqlite3.so, so a solution is to just tell
your system to
ln -s libsqlite3.so.0 libsqlite3.so
at /usr/lib/x86_64-linux-gnu.
(*) Running LOOP
First, try it out.
$ cd /path/to/loop/home
$ ./loop
200 Welcome! Say ``help'' for a menu.
$ ./loop.exe
200 Welcome! I am LOOP 9575ac2. Say ``help'' for a menu.
quit
205 Good-bye.
@ -72,19 +48,23 @@ LOOP requires authentication for most things, so you should create an
account for you right away. Accounts are kept in accounts.lisp in
your installation directory. Every time you create an account, you
must specify who is inviting this new account into the loop---because
we keep a tree of accounts. The root account is called anonymous, so
your first account must be invited by the anonymous account. So you
can say
we keep a tree of accounts. So say
./loop --create-account you anonymous
./loop --create-account you root
The anonymous account has no special power; it exists solely because
the graph of accounts needs a root.
to create YOU, your account. The root account has no special power;
it exists solely because a tree of accounts needs a root. It's an
account like any other, so you could use it yourself. In that case,
change its password:
$ ./loop --change-passwd root <secret>
Okay, account root now has password ``<secret>''.
(*) How to expose LOOP to the network
Run your TCP server of choice. For instance, if you're using djb's
tcpserver and would like LOOP to listen on port 1024, tell your shell
Just run your TCP server of choice. For instance, if you're using
djb's tcpserver and would like LOOP to listen on port 1024, tell your
shell
--8<-------------------------------------------------------->8---
$ tcpserver -v -HR 0.0.0.0 1024 ./loop -s
@ -137,3 +117,27 @@ scripts/cron-remove-inactive-users.lisp. Here's our crontab:
$ crontab -l
@daily cd /path/to/loop/home && sbcl --script scripts/cron-remove-inactive-users.lisp
(*) Systems with no installation issues
We installed LOOP just fine on
FreeBSD 14.1, 14.2 with SBCL 2.4.9.
Debian GNU/Linux 8.11 codename jessie with SBCL 1.2.4.debian.
(*) Systems with installation issues
We installed LOOP on Ubuntu 24.04 (24.01.1 LTS) codename noble with
SBCL 2.2.9.debian. We found that CLSQL could not load the shared
object libsqlite3.so because ``apt install libsqlite3'' installs the
library at
/usr/lib/x86_64-linux-gnu/libsqlite3.so.0.8.6
with a symbolic link to libsqlite3.so.0, but not to libsqlite3.so.
SBCL is trying to load libsqlite3.so, so a solution is to just tell
your system to
ln -s libsqlite3.so.0 libsqlite3.so
at /usr/lib/x86_64-linux-gnu.

4
accounts.lisp
View file

@ -1,6 +1,6 @@
(#S(LOOP::ACCOUNT
:USERNAME "ANONYMOUS"
:SEEN 3935609919
:USERNAME "ROOT"
:SEEN 3943637447
:LAST-POST NIL
:FRIENDS NIL
:PASS NIL

27
format-def Normal file
View file

@ -0,0 +1,27 @@
#!/bin/sh
usage()
{
printf 'usage: %s [file.lisp]\n' $0
exit 1
}
## The first program finds certain definitions and inserts a new blank
## line *before* the definition. Such action makes function
## definitions separated by two blank lines in some cases. We then
## remove the excess with the second program. Notice we need the -E
## option because we're using the | metacharacter that is only
## supported by popular sed programs with the -E option. This
## violates POSIX sed, but keep in mind that we only run this when
## releasing the package. This is a building tool, not part of the
## service.
sed -E '/^\(defun |\(defmacro /{
i\
}' $* | sed '/^[ \t]*$/{
N
/^[ \t]*\n$/D
}'
## We first find a blank line. Then we say N to expand the pattern
## space to include the next line. Then we delete the *first* blank
## line and not the second---that's what the D command does. This
## strategy is explained by Dale Dougherty and Arnold Robbins in ``sed
## & awk'' second edition, pages 112--114.

4
loop.asd
View file

@ -1,6 +1,6 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*-
(asdf:defsystem :loop
:version "0.1"
(asdf:defsystem :LOOP
:version "3719590"
:description "An NNTP server for a circle of friends."
:depends-on (:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon
:filesystem-utils :ironclad/digest/sha256)

109
loop.lisp
View file

@ -30,6 +30,7 @@
(defparameter *months-inactive-allowed* 3)
(defparameter *months-never-logged-in* 1)
(defvar *debug* nil)
(defun table-of-commands ()
`(("GROUP" ,#'cmd-group "sets the current group")
("NEXT" ,#'cmd-next "increments the article pointer")
@ -80,6 +81,7 @@
:verb 'unrecognized
:description "a command for all commands typed wrong")))
(or (cdr cmd) (unrecognized-command)))))
(defmacro in-dir (dir &rest body)
`(let ((*default-pathname-defaults* (truename ,dir)))
(uiop:with-current-directory (,dir)
@ -124,6 +126,13 @@
(make-response :code 400 :data "You must authenticate first.")
(progn ,@body)))
(defun conforms-to? (s re &optional error-msg)
"Does string S conform to regular expression RE?"
(let ((okay? (cl-ppcre:scan-to-strings re s)))
(if okay?
(values t nil)
(values nil (or error-msg (fmt "must match ~a" re))))))
(defun print/finish (&rest args)
(apply #'format (cons t args))
(finish-output))
@ -187,6 +196,7 @@
(defmacro mac (&rest body)
`(macroexpand-1 ,@body))
(defun repl (r)
(in-package :loop)
(loop
@ -216,13 +226,16 @@
"Oops: ~a~%"
(str:collapse-whitespaces
(str:replace-all (string #\linefeed) " " (fmt "~a" c))))))))
(defun empty-response () (make-response :code 400 :data "I beg your pardon?"))
(defun prepend-response-with (message r)
(make-response
:code (response-code r)
:data (data message (crlf) (response-data r))
:multi-line (response-multi-line r)
:request (response-request r)))
(defun append-crlf-if-needed (seq)
(cond
((stringp seq)
@ -244,10 +257,12 @@
(stderr ">>> ~a" (bytes->string (ucs-2->ascii bs)))))
(force-output)
r)
(defun my-write (ls-of-bytes s)
(if (interactive-stream-p s)
(write-sequence (mapcar #'code-char ls-of-bytes) s)
(write-sequence ls-of-bytes s)))
(defun parse-request (r)
(let* ((collapsed-s (str:collapse-whitespaces (request-said r)))
(ls (str:split " " collapsed-s :omit-nulls 'please)))
@ -258,6 +273,7 @@
(make-request :said (request-said r)
:verb (str:upcase verb)
:args args))))))
(defun insert-index (m g i)
(handler-case
(clsql:insert-records
@ -283,6 +299,7 @@
(art (second article)))
(when found
(values grp art))))
(defun connect-index! (filename)
(setq *default-database* (clsql:connect (list filename) :database-type :sqlite3)))
@ -295,6 +312,7 @@
(defun drop-create-index! ()
(clsql:execute-command "drop table if exists indices")
(create-index!))
(defun remove-inactive-users! ()
(loop for u in *accounts* do
(let ((username (account-username u)))
@ -319,6 +337,7 @@
(fmt "disappeared for over ~a months"
*months-inactive-allowed*))
(format t "Locked ~a due to long-time-no-see.~%" username))))))
(defun remove-account! (username)
(loop for u in *accounts* do
(setf (account-friends u)
@ -332,6 +351,7 @@
(setf (account-pass-locked u) (account-pass u))
(setf (account-pass u) "locked")
(setf (account-pass-locked-why u) why)))
(defun user-inactive? (username)
(or (inactive-from-never-logged-in? username)
(inactive-from-last-seen? username)))
@ -382,6 +402,7 @@
(format t "Username ~a is inactive? ~a~%"
(account-username u)
(user-inactive? (account-username u)))))
(defun loop-epoch ()
(encode-timestamp 0 0 0 0 1 1 2024))
@ -392,6 +413,7 @@
(setf (account-creation u) (timestamp-to-universal (loop-epoch)))
(setf (account-last-post u) (account-seen u))))
(write-accounts!))
(defun split-vector (delim v acc &key limit (so-far 1))
(let ((len (length v)))
(split-vector-helper delim v len acc limit so-far 0)))
@ -410,6 +432,7 @@
limit
(1+ so-far)
(+ pos (length delim))))))))
(defun index-from-fs! ()
(loop for path in (in-groups (directory "**/*"))
do (let* ((g (str:trim (first (last (pathname-directory path)))))
@ -422,6 +445,7 @@
(defun remake-index-from-fs ()
(drop-create-index!)
(index-from-fs!))
(defun parse-article (v)
(let ((parts (split-vector (vector 13 10 13 10) v nil :limit 2)))
(make-article :headers (map 'string #'code-char (car parts)) :body (cadr parts))))
@ -449,6 +473,7 @@
(mapcar #'(lambda (h) (parse-header h)) ls)))
(defun string-integer? (s) (ignore-errors (parse-integer s)))
(defun get-header-from-article (h a)
(get-header h (parse-headers (article-headers (parse-article a)))))
@ -468,6 +493,7 @@
("byte-count" . ,(format nil "~a" (length a))))))
(defun nlines (v) (length (split-vector (crlf) v nil)))
(defun fetch-article (g i)
(in-groups
(read-file-raw (format nil "~a/~a" g i))))
@ -485,11 +511,15 @@
(defun fetch-body (g i)
(article-body (parse-article (fetch-article g i))))
(defun encode-body (a) a)
(defun extract-mid (a)
(lookup "message-id" (parse-headers (article-headers (parse-article a)))))
(defun lookup (key table)
(cdr (assoc key table :test #'string=)))
(defun dispatch (r)
(let* ((verb (request-verb r)))
(if (null verb)
@ -498,6 +528,7 @@
(defun dispatch-line (ln)
(dispatch (parse-request (make-request :said ln))))
(defun cmd-authinfo (r)
(let* ((args (mapcar #'str:upcase (request-args r))))
(cond
@ -531,8 +562,10 @@
(let ((u (get-account (client-username *client*))))
(setf (account-seen u) (get-universal-time)))
(write-accounts!))
(defun cmd-mode (r) ;; Whatever.
(make-response :code 200 :request r :data "Sure thing."))
(defun typical-cmd-head-body-article (r fn-name)
(with-auth
(with-group-set
@ -551,17 +584,22 @@
(defun cmd-head (r)
(typical-cmd-head-body-article r #'head-response))
(defun cmd-body (r)
(typical-cmd-head-body-article r #'body-response))
(defun cmd-article (r)
(typical-cmd-head-body-article r #'article-response))
(defun article-response (r g i)
(typical-cmd-response 220 r g i #'(lambda (a) (encode-body a))))
(defun head-response (r g i)
(typical-cmd-response 221 r g i #'(lambda (a) (article-headers (parse-article a)))))
(defun body-response (r g i)
(typical-cmd-response 222 r g i #'(lambda (a) (encode-body (article-body (parse-article a))))))
(defun typical-cmd-response (code r g i get-data)
(handler-case
(let ((a (fetch-article g i)))
@ -578,6 +616,7 @@
(make-response
:code 400 :request r
:data (format nil "article ~a/~a: ~a" g i c)))))
(defun cmd-next (r)
(with-auth
(let ((g (client-group *client*))
@ -598,6 +637,7 @@
(defun mid-by-name (g name)
(extract-mid (fetch-article g name)))
(defun cmd-xover (r)
(with-auth
(with-group-set
@ -638,13 +678,16 @@
(member (car h) (xover-headers)
:test #'string=))
(fetch-headers g i)))))))))))
(defun xover-format-line (i hs)
(str:concat (format nil "~a~a" i #\tab)
(str:join #\tab
(mapcar #'(lambda (h) (get-header h hs))
(xover-headers)))))
(defun xover-headers ()
'("subject" "from" "date" "message-id" "references" "line-count" "byte-count"))
(defun cmd-group (r)
(with-auth
(with-n-args 1 r
@ -776,11 +819,13 @@
#'string-lessp)))
(defun last-char (s) (char s (1- (length s))))
(defun basename (path)
(let ((s (str:collapse-whitespaces path)))
(if (char= #\/ (last-char s))
(car (last (pathname-directory s)))
(file-namestring s))))
(defun cmd-help (r)
(let ((lines (menu *commands-assoc*)))
(prepend-response-with
@ -788,23 +833,26 @@
(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)))))
(loop for item in ls
collect (display-fn (car ls))))
(defun display-fn (cmd-pair)
(let ((cmd (cdr cmd-pair)))
(format nil "~A ~A"
(command-verb cmd)
(command-description cmd))))
(defun cmd-quit (r)
(make-response :code 205 :data "Good-bye." :request r))
(defun cmd-date (r)
(make-response :code 201
:request r
:data
(format-timestring nil (now))))
(defun conforms? (bs)
(catch 'article-syntax-error ;; parse-headers might throw
(let ((headers (parse-headers (article-headers (parse-article bs)))))
@ -829,6 +877,7 @@
(defun headers-required-from-clients ()
'("from" "newsgroups" "subject"))
(defun suggest-message-id (&optional (n 20))
(format nil "<~a@loop>" (random-string n)))
@ -840,6 +889,7 @@
(dotimes (c size)
(setq mid (cons (char universe (random len state)) mid)))
(coerce mid 'string)))
(defun unparse-article (parsed)
(data
(let ((ls))
@ -848,6 +898,7 @@
(nreverse ls))
(crlf)
(article-body parsed)))
(defun ensure-header (h fn bs)
(let* ((headers (parse-headers (article-headers (parse-article bs)))))
(if (lookup h headers)
@ -870,8 +921,10 @@
(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)))
@ -910,9 +963,11 @@
(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)))
@ -936,6 +991,7 @@
:element-type '(unsigned-byte 8))
(write-sequence bs s))
(rename-no-extension tmp name)))
(defun save-article-insist (g name a message-id)
(loop for name from name do
(in-dir (format nil "groups/~a/" g)
@ -946,12 +1002,14 @@
(multiple-value-bind (low high len) (group-high-low g)
(declare (ignore low len))
(1+ high)))
(defun nntp-read-article (&optional acc)
;; Returns List-of Byte.
(let* ((ls (ucs-2->ascii (nntp-read-line))))
(cond ;; 46 == (byte #\.)
((equal (list 46) ls) (flatten (add-crlf-between acc)))
(t (nntp-read-article (append acc (list ls)))))))
(defun nntp-read-line (&optional (s *standard-input*) acc)
;; Returns List-of Byte.
(let ((x (read-byte s)))
@ -984,6 +1042,7 @@
(defun bytes->string (ls)
(map 'string #'code-char ls))
(defun cmd-create-group (r)
(with-n-args 1 r
(let ((g (string-downcase (car (request-args r)))))
@ -1008,10 +1067,11 @@
: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]+)"))))
(conforms-to? g "^[^\\s/]+$"))
(defun user-name-conforms? (u)
(conforms-to? u "^[^\\s]+$"))
(defun cmd-create-account (r)
(with-auth
(with-n-args 1 r
@ -1026,6 +1086,7 @@
(make-response :code 200 :request r
:data (fmt "Okay, account ~a created with password ``~a''."
username pass-or-error)))))))))
(defun read-accounts! ()
(let ((*package* (find-package '#:loop)))
(with-open-file
@ -1049,13 +1110,18 @@
(a (make-account :username u
:pass (string->sha256 (str:upcase p))
:creation (get-universal-time))))
(if (get-account u)
(values nil (fmt "account ~a already exists" u))
(progn
(multiple-value-bind (okay? reason)
(user-name-conforms? u)
(cond ((not okay?)
(values nil (fmt "username must conform to ^[^\\s]+$")))
((get-account u)
(values nil (fmt "account ~a already exists" u)))
(t
(push u (account-friends (get-account invited-by)))
(push a *accounts*)
(write-accounts!)
(values (str:upcase username) p)))))
(values (str:upcase username) p))))))
(defun write-accounts! ()
(let ((name
(loop
@ -1078,6 +1144,7 @@
(loop for u in *accounts*
do (when (string= (str:upcase username) (account-username u))
(return u))))
(defun cmd-unlock-account (r)
(with-auth
(with-n-args 1 r
@ -1105,6 +1172,7 @@
(setf (account-pass u) (account-pass-locked u))
(setf (account-pass-locked u) nil)
(setf (account-pass-locked-why u) nil)))))
(defun cmd-login (r)
(let* ((args (mapcar #'str:upcase (request-args r))))
(cond
@ -1123,6 +1191,7 @@
(defun log-user-in-as! (name)
(setf (client-username *client*) name)
(log-user-in!))
(defun cmd-passwd (r)
(with-auth
(let* ((args (mapcar #'str:upcase (request-args r))))
@ -1200,8 +1269,10 @@
(let ((u (get-account username)))
(if u (let ((s (account-seen u)))
(if s (universal-to-human s))))))
(defun cmd-dd (r)
(make-response :code 200 :data (format nil "state: ~a" *client*) :request r))
(defun cmd-repl (r)
(with-auth
(repl r)))
@ -1243,12 +1314,12 @@
(list
(clingon:make-option
:string
:description "<username> <invited-by> creates a new account"
:description "creates a new account"
:long-name "create-account"
:key :create-account)
(clingon:make-option
:string
:description "<username> <new-password> changes password"
:description "changes password"
:long-name "change-passwd"
:key :change-passwd)
(clingon:make-option
@ -1268,6 +1339,7 @@
:description "logging (on stderr)"
:long-name "logging"
:key :logging)))
(defun cli/list-accounts ()
(println (str:join (crlf-string) (list-users))))
@ -1293,10 +1365,10 @@
(new-passwd (or given-passwd random-passwd)))
(if (not (get-account username))
(println "No such account ``~a''." username)
(multiple-value-bind (okay? problem) (change-passwd! username new-passwd)
(if okay?
(multiple-value-bind (okay? problem) (change-passwd! username new-passwd) (if okay?
(println "Okay, account ~a now has password ``~a''." username new-passwd)
(println "Sorry, could not change password: ~a." problem))))))
(defun cli/main-with-handlers (cmd)
(handler-case
(cli/main cmd)
@ -1333,7 +1405,7 @@
(clingon:make-command
:name "loop"
:description "An NNTP server for a circle of friends."
:version "0.1"
:version "3719590"
:license "GPL v3"
:options (cli/options)
:handler #'cli/main-with-handlers))
@ -1347,6 +1419,7 @@
(return))))))
(defun request-quit? (r) (and r (string= 'quit (request-verb r))))
(defun response-quit? (r) (and r (request-quit? (response-request r))))
(defun server-start ()
@ -1360,7 +1433,9 @@
(defun send-banner! ()
(send-response!
(make-response :code 200 :data "Welcome! Say ``help'' for a menu.")))
(make-response
:code 200
:data "Welcome! I am LOOP 3719590. Say ``help'' for a menu.")))
(setq lisp-unit:*print-failures* t)
(define-test first-test-of-the-west

185
loop.nw
View file

@ -323,6 +323,7 @@ Section~\ref{sec:repl}. Commands such as [[CREATE-ACCOUNT]],
users need to know how to use {\tt nc} or {\tt telnet} to take
advantage of all of \lp's capabilities.
\section{NNTP protocol}
An Internet protocol is usually defined by a document whose tradition
@ -432,18 +433,6 @@ line, which is what causes that 400 response.
(str:replace-all (string #\linefeed) " " (fmt "~a" c))))))))
@ %def repl
\section{Description of the package}
<<Description>>=
An NNTP server for a circle of friends.
@
<<Version>>=
0.1
@
These chunks are used in [[loop.asd]].
\section{Representation of a client}
How do we represent a client? A client is typically reading a group
@ -601,25 +590,6 @@ else should we handle this?
(write-sequence ls-of-bytes s)))
@ %def my-write
\section{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.
<<Procedures for requests and responses>>=
(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{Main loop}
Every command consumes a [[request]] and produces a [[response]]. If
@ -657,27 +627,78 @@ itself---so we can cascade actions based on a user's request.
(defun send-banner! ()
(send-response!
(make-response :code 200 :data "Welcome! Say ``help'' for a menu.")))
(make-response
:code 200
:data "<<Welcome message>>")))
@ %def main main-loop
\noindent It's always useful to know which version exactly we're
dealing with:
%
\begin{verbatim}
%./loop.exe
200 Welcome! I am LOOP 9575ac2. Say ``help'' for a menu.
\end{verbatim}
%
So we put a release tag on \lp's banner.
<<Welcome message>>=
Welcome! I am <<Name>> <<Version>>. Say ``help'' for a menu.
@
\noindent We take the opportunity and describe \lp's package,
information which we also use in [[loop.asd]].
<<Name>>=
LOOP
@
<<Description>>=
An NNTP server for a circle of friends.
@
<<Version>>=
3719590
@
\section{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.
<<Procedures for requests and responses>>=
(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{Parsing of command-line arguments}
We're using the clingon library as per Vincent Dardel suggestion in
``The Common Lisp Cookbook''. We begin with writing a description of
the program and options it understands. XXX: notice I don't know how
to support a two-argument option, so I hacked a solution away.
to support a two-argument option, so I hacked a solution away. What
we need to is to implement a new option. The library is extensible.
<<Command-line parsing>>=
(defun cli/options ()
(list
(clingon:make-option
:string
:description "<username> <invited-by> creates a new account"
:description "creates a new account"
:long-name "create-account"
:key :create-account)
(clingon:make-option
:string
:description "<username> <new-password> changes password"
:description "changes password"
:long-name "change-passwd"
:key :change-passwd)
(clingon:make-option
@ -699,12 +720,9 @@ to support a two-argument option, so I hacked a solution away.
:key :logging)))
@
The command-line options form a language. The user specifies
everything he wants with flags. If he wants nothing, for instance, he
specifies nothing and then nothing happens. XXX: I'd like to have a
default action (which would be running the server) that is invoked by
default if none of the other options would run. But I don't know how
to do that yet.
We implement first the procedures that handle options that represent
an entire program. For example, saying [[--list-accounts]] is like
running a program [[./list-accounts]].
<<Command-line parsing>>=
(defun cli/list-accounts ()
@ -732,13 +750,15 @@ to do that yet.
(new-passwd (or given-passwd random-passwd)))
(if (not (get-account username))
(println "No such account ``~a''." username)
(multiple-value-bind (okay? problem) (change-passwd! username new-passwd)
(if okay?
(multiple-value-bind (okay? problem) (change-passwd! username new-passwd) (if okay?
(println "Okay, account ~a now has password ``~a''." username new-passwd)
(println "Sorry, could not change password: ~a." problem))))))
@ %def cli/change-passwd cli/list-accounts cli/create-account
Now let's write the main procedure in command-line parsing.
Now let's write the main procedure in command-line parsing. Notice
that because of the design of the [[clingon]] library, command-line
parsing becomes the main procedure of \lp. In other words, \lp's
service starts with [[server-start]].
<<Command-line parsing>>=
(defun cli/main-with-handlers (cmd)
@ -947,8 +967,7 @@ 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.} XXX: replace menu with
[[loop]].
reason to think we're doing to debug it.}
<<Command help>>=
(defun cmd-help (r)
@ -958,10 +977,10 @@ reason to think we're doing to debug it.} XXX: replace menu with
(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)))))
(loop for item in ls
collect (display-fn (car ls))))
(defun display-fn (cmd-pair)
(let ((cmd (cdr cmd-pair)))
@ -1023,10 +1042,26 @@ Syntax error. Say ``authinfo USER /your-name/'' then ``authinfo PASS /your-pass/
\subsection{{\tt CREATE-ACCOUNT}}
We allow authenticated members to invite their friends. Notice that
we're not doing any kind of checking on the username. XXX: take a
look at how we verify group names match a certain regex and apply the
same check here.
We allow authenticated members to invite their friends, which creates
a tree of people. ({\em An idea}. We could envision that each tree
trunk manages the rest of the tree underneath it. So I invite you, I
could change your password, say, or handle any problems you might
have. This decentralizes system administration, easing the support
burden.)
The name of each user must conform to the expression
<<Form of user names>>=
^[^\\s]+$
@
Same as in @<<Form of newsgroup names@>>. We'll let users create
whatever complicated user names they want. If they can type it up,
it's their problem.
<<Command create-account>>=
(defun user-name-conforms? (u)
(conforms-to? u "<<Form of user names>>"))
<<Command create-account>>=
(defun cmd-create-account (r)
@ -1074,13 +1109,17 @@ same check here.
(a (make-account :username u
:pass (string->sha256 (str:upcase p))
:creation (get-universal-time))))
(if (get-account u)
(values nil (fmt "account ~a already exists" u))
(progn
(multiple-value-bind (okay? reason)
(user-name-conforms? u)
(cond ((not okay?)
(values nil (fmt "username must conform to <<Form of user names>>")))
((get-account u)
(values nil (fmt "account ~a already exists" u)))
(t
(push u (account-friends (get-account invited-by)))
(push a *accounts*)
(write-accounts!)
(values (str:upcase username) p)))))
(values (str:upcase username) p))))))
@ %def CREATE-ACCOUNT new-account!
Notice that we have a race condition in [[write-accounts]]. What is
@ -1743,13 +1782,19 @@ then we verify the list of newsgroups right away.
The name of each group must conform to the expression
<<Form of newsgroup names>>=
^([a-z0-9]+)
@ %def the-form-of-newsgroup-names
^[^\\s/]+$
@
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.
In other words, let group names go wild. They cannot contain a slash
or a space of any kind anywhere on the name---more literally: they
must begin with any character that's not a space and must have at
least one character. The problem wish slashes is that each group will
be a directory on a UNIX file system, so we cannot let slashes appear.
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.
<<Command post>>=
(defun newsgroups-header->list (s)
@ -2023,10 +2068,7 @@ all or it has been discussed with the community beforehand.
:data (format nil "group ~a created" g)))))))))))
(defun group-name-conforms? (g)
(let ((okay? (cl-ppcre:scan-to-strings "<<Form of newsgroup names>>" g)))
(if okay?
(values t nil)
(values nil "must match <<Form of newsgroup names>>"))))
(conforms-to? g "<<Form of newsgroup names>>"))
@ %def CREATE-GROUP group-name-conforms?
\subsection{{\tt REPL}}
@ -2555,6 +2597,13 @@ stands for ``Universal Character Set'' and I speculate the number 2
means 2 bytes. So our conversion is just removing the first byte.
<<Little procedures>>=
(defun conforms-to? (s re &optional error-msg)
"Does string S conform to regular expression RE?"
(let ((okay? (cl-ppcre:scan-to-strings re s)))
(if okay?
(values t nil)
(values nil (or error-msg (fmt "must match ~a" re))))))
(defun print/finish (&rest args)
(apply #'format (cons t args))
(finish-output))
@ -2804,7 +2853,7 @@ The \lp\ system definition:
<<loop.asd>>=
;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*-
(asdf:defsystem :loop
(asdf:defsystem :<<Name>>
:version "<<Version>>"
:description "<<Description>>"
:depends-on (<<List of packages to be loaded>>)

14
make-release Normal file
View file

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