Identifies each binary with a version tag.

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 f0a54bf1f9
6 changed files with 232 additions and 38 deletions

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

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.

View file

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

View file

@ -30,6 +30,7 @@
(defparameter *months-inactive-allowed* 3) (defparameter *months-inactive-allowed* 3)
(defparameter *months-never-logged-in* 1) (defparameter *months-never-logged-in* 1)
(defvar *debug* nil) (defvar *debug* nil)
(defun table-of-commands () (defun table-of-commands ()
`(("GROUP" ,#'cmd-group "sets the current group") `(("GROUP" ,#'cmd-group "sets the current group")
("NEXT" ,#'cmd-next "increments the article pointer") ("NEXT" ,#'cmd-next "increments the article pointer")
@ -80,6 +81,7 @@
:verb 'unrecognized :verb 'unrecognized
:description "a command for all commands typed wrong"))) :description "a command for all commands typed wrong")))
(or (cdr cmd) (unrecognized-command))))) (or (cdr cmd) (unrecognized-command)))))
(defmacro in-dir (dir &rest body) (defmacro in-dir (dir &rest body)
`(let ((*default-pathname-defaults* (truename ,dir))) `(let ((*default-pathname-defaults* (truename ,dir)))
(uiop:with-current-directory (,dir) (uiop:with-current-directory (,dir)
@ -187,6 +189,7 @@
(defmacro mac (&rest body) (defmacro mac (&rest body)
`(macroexpand-1 ,@body)) `(macroexpand-1 ,@body))
(defun repl (r) (defun repl (r)
(in-package :loop) (in-package :loop)
(loop (loop
@ -216,13 +219,16 @@
"Oops: ~a~%" "Oops: ~a~%"
(str:collapse-whitespaces (str:collapse-whitespaces
(str:replace-all (string #\linefeed) " " (fmt "~a" c)))))))) (str:replace-all (string #\linefeed) " " (fmt "~a" c))))))))
(defun empty-response () (make-response :code 400 :data "I beg your pardon?")) (defun empty-response () (make-response :code 400 :data "I beg your pardon?"))
(defun prepend-response-with (message r) (defun prepend-response-with (message r)
(make-response (make-response
:code (response-code r) :code (response-code r)
:data (data message (crlf) (response-data r)) :data (data message (crlf) (response-data r))
:multi-line (response-multi-line r) :multi-line (response-multi-line r)
:request (response-request r))) :request (response-request r)))
(defun append-crlf-if-needed (seq) (defun append-crlf-if-needed (seq)
(cond (cond
((stringp seq) ((stringp seq)
@ -244,10 +250,12 @@
(stderr ">>> ~a" (bytes->string (ucs-2->ascii bs))))) (stderr ">>> ~a" (bytes->string (ucs-2->ascii bs)))))
(force-output) (force-output)
r) r)
(defun my-write (ls-of-bytes s) (defun my-write (ls-of-bytes s)
(if (interactive-stream-p s) (if (interactive-stream-p s)
(write-sequence (mapcar #'code-char ls-of-bytes) s) (write-sequence (mapcar #'code-char ls-of-bytes) s)
(write-sequence ls-of-bytes s))) (write-sequence ls-of-bytes s)))
(defun parse-request (r) (defun parse-request (r)
(let* ((collapsed-s (str:collapse-whitespaces (request-said r))) (let* ((collapsed-s (str:collapse-whitespaces (request-said r)))
(ls (str:split " " collapsed-s :omit-nulls 'please))) (ls (str:split " " collapsed-s :omit-nulls 'please)))
@ -258,6 +266,7 @@
(make-request :said (request-said r) (make-request :said (request-said r)
:verb (str:upcase verb) :verb (str:upcase verb)
:args args)))))) :args args))))))
(defun insert-index (m g i) (defun insert-index (m g i)
(handler-case (handler-case
(clsql:insert-records (clsql:insert-records
@ -283,6 +292,7 @@
(art (second article))) (art (second article)))
(when found (when found
(values grp art)))) (values grp art))))
(defun connect-index! (filename) (defun connect-index! (filename)
(setq *default-database* (clsql:connect (list filename) :database-type :sqlite3))) (setq *default-database* (clsql:connect (list filename) :database-type :sqlite3)))
@ -295,6 +305,7 @@
(defun drop-create-index! () (defun drop-create-index! ()
(clsql:execute-command "drop table if exists indices") (clsql:execute-command "drop table if exists indices")
(create-index!)) (create-index!))
(defun remove-inactive-users! () (defun remove-inactive-users! ()
(loop for u in *accounts* do (loop for u in *accounts* do
(let ((username (account-username u))) (let ((username (account-username u)))
@ -319,6 +330,7 @@
(fmt "disappeared for over ~a months" (fmt "disappeared for over ~a months"
*months-inactive-allowed*)) *months-inactive-allowed*))
(format t "Locked ~a due to long-time-no-see.~%" username)))))) (format t "Locked ~a due to long-time-no-see.~%" username))))))
(defun remove-account! (username) (defun remove-account! (username)
(loop for u in *accounts* do (loop for u in *accounts* do
(setf (account-friends u) (setf (account-friends u)
@ -332,6 +344,7 @@
(setf (account-pass-locked u) (account-pass u)) (setf (account-pass-locked u) (account-pass u))
(setf (account-pass u) "locked") (setf (account-pass u) "locked")
(setf (account-pass-locked-why u) why))) (setf (account-pass-locked-why u) why)))
(defun user-inactive? (username) (defun user-inactive? (username)
(or (inactive-from-never-logged-in? username) (or (inactive-from-never-logged-in? username)
(inactive-from-last-seen? username))) (inactive-from-last-seen? username)))
@ -382,6 +395,7 @@
(format t "Username ~a is inactive? ~a~%" (format t "Username ~a is inactive? ~a~%"
(account-username u) (account-username u)
(user-inactive? (account-username u))))) (user-inactive? (account-username u)))))
(defun loop-epoch () (defun loop-epoch ()
(encode-timestamp 0 0 0 0 1 1 2024)) (encode-timestamp 0 0 0 0 1 1 2024))
@ -392,6 +406,7 @@
(setf (account-creation u) (timestamp-to-universal (loop-epoch))) (setf (account-creation u) (timestamp-to-universal (loop-epoch)))
(setf (account-last-post u) (account-seen u)))) (setf (account-last-post u) (account-seen u))))
(write-accounts!)) (write-accounts!))
(defun split-vector (delim v acc &key limit (so-far 1)) (defun split-vector (delim v acc &key limit (so-far 1))
(let ((len (length v))) (let ((len (length v)))
(split-vector-helper delim v len acc limit so-far 0))) (split-vector-helper delim v len acc limit so-far 0)))
@ -410,6 +425,7 @@
limit limit
(1+ so-far) (1+ so-far)
(+ pos (length delim)))))))) (+ pos (length delim))))))))
(defun index-from-fs! () (defun index-from-fs! ()
(loop for path in (in-groups (directory "**/*")) (loop for path in (in-groups (directory "**/*"))
do (let* ((g (str:trim (first (last (pathname-directory path))))) do (let* ((g (str:trim (first (last (pathname-directory path)))))
@ -422,6 +438,7 @@
(defun remake-index-from-fs () (defun remake-index-from-fs ()
(drop-create-index!) (drop-create-index!)
(index-from-fs!)) (index-from-fs!))
(defun parse-article (v) (defun parse-article (v)
(let ((parts (split-vector (vector 13 10 13 10) v nil :limit 2))) (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)))) (make-article :headers (map 'string #'code-char (car parts)) :body (cadr parts))))
@ -449,6 +466,7 @@
(mapcar #'(lambda (h) (parse-header h)) ls))) (mapcar #'(lambda (h) (parse-header h)) ls)))
(defun string-integer? (s) (ignore-errors (parse-integer s))) (defun string-integer? (s) (ignore-errors (parse-integer s)))
(defun get-header-from-article (h a) (defun get-header-from-article (h a)
(get-header h (parse-headers (article-headers (parse-article a))))) (get-header h (parse-headers (article-headers (parse-article a)))))
@ -468,6 +486,7 @@
("byte-count" . ,(format nil "~a" (length a)))))) ("byte-count" . ,(format nil "~a" (length a))))))
(defun nlines (v) (length (split-vector (crlf) v nil))) (defun nlines (v) (length (split-vector (crlf) v nil)))
(defun fetch-article (g i) (defun fetch-article (g i)
(in-groups (in-groups
(read-file-raw (format nil "~a/~a" g i)))) (read-file-raw (format nil "~a/~a" g i))))
@ -485,11 +504,15 @@
(defun fetch-body (g i) (defun fetch-body (g i)
(article-body (parse-article (fetch-article g i)))) (article-body (parse-article (fetch-article g i))))
(defun encode-body (a) a) (defun encode-body (a) a)
(defun extract-mid (a) (defun extract-mid (a)
(lookup "message-id" (parse-headers (article-headers (parse-article a))))) (lookup "message-id" (parse-headers (article-headers (parse-article a)))))
(defun lookup (key table) (defun lookup (key table)
(cdr (assoc key table :test #'string=))) (cdr (assoc key table :test #'string=)))
(defun dispatch (r) (defun dispatch (r)
(let* ((verb (request-verb r))) (let* ((verb (request-verb r)))
(if (null verb) (if (null verb)
@ -498,6 +521,7 @@
(defun dispatch-line (ln) (defun dispatch-line (ln)
(dispatch (parse-request (make-request :said ln)))) (dispatch (parse-request (make-request :said ln))))
(defun cmd-authinfo (r) (defun cmd-authinfo (r)
(let* ((args (mapcar #'str:upcase (request-args r)))) (let* ((args (mapcar #'str:upcase (request-args r))))
(cond (cond
@ -531,8 +555,10 @@
(let ((u (get-account (client-username *client*)))) (let ((u (get-account (client-username *client*))))
(setf (account-seen u) (get-universal-time))) (setf (account-seen u) (get-universal-time)))
(write-accounts!)) (write-accounts!))
(defun cmd-mode (r) ;; Whatever. (defun cmd-mode (r) ;; Whatever.
(make-response :code 200 :request r :data "Sure thing.")) (make-response :code 200 :request r :data "Sure thing."))
(defun typical-cmd-head-body-article (r fn-name) (defun typical-cmd-head-body-article (r fn-name)
(with-auth (with-auth
(with-group-set (with-group-set
@ -551,17 +577,22 @@
(defun cmd-head (r) (defun cmd-head (r)
(typical-cmd-head-body-article r #'head-response)) (typical-cmd-head-body-article r #'head-response))
(defun cmd-body (r) (defun cmd-body (r)
(typical-cmd-head-body-article r #'body-response)) (typical-cmd-head-body-article r #'body-response))
(defun cmd-article (r) (defun cmd-article (r)
(typical-cmd-head-body-article r #'article-response)) (typical-cmd-head-body-article r #'article-response))
(defun article-response (r g i) (defun article-response (r g i)
(typical-cmd-response 220 r g i #'(lambda (a) (encode-body a)))) (typical-cmd-response 220 r g i #'(lambda (a) (encode-body a))))
(defun head-response (r g i) (defun head-response (r g i)
(typical-cmd-response 221 r g i #'(lambda (a) (article-headers (parse-article a))))) (typical-cmd-response 221 r g i #'(lambda (a) (article-headers (parse-article a)))))
(defun body-response (r g i) (defun body-response (r g i)
(typical-cmd-response 222 r g i #'(lambda (a) (encode-body (article-body (parse-article a)))))) (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) (defun typical-cmd-response (code r g i get-data)
(handler-case (handler-case
(let ((a (fetch-article g i))) (let ((a (fetch-article g i)))
@ -578,6 +609,7 @@
(make-response (make-response
:code 400 :request r :code 400 :request r
:data (format nil "article ~a/~a: ~a" g i c))))) :data (format nil "article ~a/~a: ~a" g i c)))))
(defun cmd-next (r) (defun cmd-next (r)
(with-auth (with-auth
(let ((g (client-group *client*)) (let ((g (client-group *client*))
@ -598,6 +630,7 @@
(defun mid-by-name (g name) (defun mid-by-name (g name)
(extract-mid (fetch-article g name))) (extract-mid (fetch-article g name)))
(defun cmd-xover (r) (defun cmd-xover (r)
(with-auth (with-auth
(with-group-set (with-group-set
@ -638,13 +671,16 @@
(member (car h) (xover-headers) (member (car h) (xover-headers)
:test #'string=)) :test #'string=))
(fetch-headers g i))))))))))) (fetch-headers g i)))))))))))
(defun xover-format-line (i hs) (defun xover-format-line (i hs)
(str:concat (format nil "~a~a" i #\tab) (str:concat (format nil "~a~a" i #\tab)
(str:join #\tab (str:join #\tab
(mapcar #'(lambda (h) (get-header h hs)) (mapcar #'(lambda (h) (get-header h hs))
(xover-headers))))) (xover-headers)))))
(defun xover-headers () (defun xover-headers ()
'("subject" "from" "date" "message-id" "references" "line-count" "byte-count")) '("subject" "from" "date" "message-id" "references" "line-count" "byte-count"))
(defun cmd-group (r) (defun cmd-group (r)
(with-auth (with-auth
(with-n-args 1 r (with-n-args 1 r
@ -715,7 +751,7 @@
#+sbcl (apply #'directory directory :resolve-symlinks NIL args) #+sbcl (apply #'directory directory :resolve-symlinks NIL args)
#-(or allegro clozure digitool clisp cmucl scl lispworks sbcl) #-(or allegro clozure digitool clisp cmucl scl lispworks sbcl)
(apply #'directory directory args)) (apply #'directory directory args))
(defun loop-list-files (directory) (defun loop-list-files (directory)
(let ((directory (pathname-utils:to-directory directory))) (let ((directory (pathname-utils:to-directory directory)))
(let* ((directory (pathname-utils:pathname* directory)) (let* ((directory (pathname-utils:pathname* directory))
@ -776,11 +812,13 @@
#'string-lessp))) #'string-lessp)))
(defun last-char (s) (char s (1- (length s)))) (defun last-char (s) (char s (1- (length s))))
(defun basename (path) (defun basename (path)
(let ((s (str:collapse-whitespaces path))) (let ((s (str:collapse-whitespaces path)))
(if (char= #\/ (last-char s)) (if (char= #\/ (last-char s))
(car (last (pathname-directory s))) (car (last (pathname-directory s)))
(file-namestring s)))) (file-namestring s))))
(defun cmd-help (r) (defun cmd-help (r)
(let ((lines (menu *commands-assoc*))) (let ((lines (menu *commands-assoc*)))
(prepend-response-with (prepend-response-with
@ -788,6 +826,7 @@
(make-response :code 200 :multi-line 'yes (make-response :code 200 :multi-line 'yes
:request r :request r
:data (str:join (crlf-string) lines))))) :data (str:join (crlf-string) lines)))))
(defun menu (ls) (defun menu (ls)
(if (null ls) (if (null ls)
nil nil
@ -798,13 +837,16 @@
(format nil "~A ~A" (format nil "~A ~A"
(command-verb cmd) (command-verb cmd)
(command-description cmd)))) (command-description cmd))))
(defun cmd-quit (r) (defun cmd-quit (r)
(make-response :code 205 :data "Good-bye." :request r)) (make-response :code 205 :data "Good-bye." :request r))
(defun cmd-date (r) (defun cmd-date (r)
(make-response :code 201 (make-response :code 201
:request r :request r
:data :data
(format-timestring nil (now)))) (format-timestring nil (now))))
(defun conforms? (bs) (defun conforms? (bs)
(catch 'article-syntax-error ;; parse-headers might throw (catch 'article-syntax-error ;; parse-headers might throw
(let ((headers (parse-headers (article-headers (parse-article bs))))) (let ((headers (parse-headers (article-headers (parse-article bs)))))
@ -829,6 +871,7 @@
(defun headers-required-from-clients () (defun headers-required-from-clients ()
'("from" "newsgroups" "subject")) '("from" "newsgroups" "subject"))
(defun suggest-message-id (&optional (n 20)) (defun suggest-message-id (&optional (n 20))
(format nil "<~a@loop>" (random-string n))) (format nil "<~a@loop>" (random-string n)))
@ -840,6 +883,7 @@
(dotimes (c size) (dotimes (c size)
(setq mid (cons (char universe (random len state)) mid))) (setq mid (cons (char universe (random len state)) mid)))
(coerce mid 'string))) (coerce mid 'string)))
(defun unparse-article (parsed) (defun unparse-article (parsed)
(data (data
(let ((ls)) (let ((ls))
@ -848,6 +892,7 @@
(nreverse ls)) (nreverse ls))
(crlf) (crlf)
(article-body parsed))) (article-body parsed)))
(defun ensure-header (h fn bs) (defun ensure-header (h fn bs)
(let* ((headers (parse-headers (article-headers (parse-article bs))))) (let* ((headers (parse-headers (article-headers (parse-article bs)))))
(if (lookup h headers) (if (lookup h headers)
@ -870,8 +915,10 @@
(defun ensure-mid (bs) (defun ensure-mid (bs)
(ensure-header "message-id" #'suggest-message-id bs)) (ensure-header "message-id" #'suggest-message-id bs))
(defun ensure-date (bs) (defun ensure-date (bs)
(ensure-header "date" #'get-date bs)) (ensure-header "date" #'get-date bs))
(defun newsgroups-header->list (s) (defun newsgroups-header->list (s)
(mapcar (lambda (n) (str:trim (string-downcase n))) (str:split "," s))) (mapcar (lambda (n) (str:trim (string-downcase n))) (str:split "," s)))
@ -910,9 +957,11 @@
(data " However, the groups " (data " However, the groups "
(str:join ", " (sort ngs-dont-exist #'string<)) (str:join ", " (sort ngs-dont-exist #'string<))
" just don't exist."))))))) " just don't exist.")))))))
(defun update-last-post-date! (username) (defun update-last-post-date! (username)
(let ((u (get-account username))) (let ((u (get-account username)))
(setf (account-last-post u) (get-universal-time)))) (setf (account-last-post u) (get-universal-time))))
(defun rename-no-extension (old new) (defun rename-no-extension (old new)
(rename-file old (make-pathname :name new :type :unspecific))) (rename-file old (make-pathname :name new :type :unspecific)))
@ -936,6 +985,7 @@
:element-type '(unsigned-byte 8)) :element-type '(unsigned-byte 8))
(write-sequence bs s)) (write-sequence bs s))
(rename-no-extension tmp name))) (rename-no-extension tmp name)))
(defun save-article-insist (g name a message-id) (defun save-article-insist (g name a message-id)
(loop for name from name do (loop for name from name do
(in-dir (format nil "groups/~a/" g) (in-dir (format nil "groups/~a/" g)
@ -946,12 +996,14 @@
(multiple-value-bind (low high len) (group-high-low g) (multiple-value-bind (low high len) (group-high-low g)
(declare (ignore low len)) (declare (ignore low len))
(1+ high))) (1+ high)))
(defun nntp-read-article (&optional acc) (defun nntp-read-article (&optional acc)
;; Returns List-of Byte. ;; Returns List-of Byte.
(let* ((ls (ucs-2->ascii (nntp-read-line)))) (let* ((ls (ucs-2->ascii (nntp-read-line))))
(cond ;; 46 == (byte #\.) (cond ;; 46 == (byte #\.)
((equal (list 46) ls) (flatten (add-crlf-between acc))) ((equal (list 46) ls) (flatten (add-crlf-between acc)))
(t (nntp-read-article (append acc (list ls))))))) (t (nntp-read-article (append acc (list ls)))))))
(defun nntp-read-line (&optional (s *standard-input*) acc) (defun nntp-read-line (&optional (s *standard-input*) acc)
;; Returns List-of Byte. ;; Returns List-of Byte.
(let ((x (read-byte s))) (let ((x (read-byte s)))
@ -984,6 +1036,7 @@
(defun bytes->string (ls) (defun bytes->string (ls)
(map 'string #'code-char ls)) (map 'string #'code-char ls))
(defun cmd-create-group (r) (defun cmd-create-group (r)
(with-n-args 1 r (with-n-args 1 r
(let ((g (string-downcase (car (request-args r))))) (let ((g (string-downcase (car (request-args r)))))
@ -1012,6 +1065,7 @@
(if okay? (if okay?
(values t nil) (values t nil)
(values nil "must match ^([a-z0-9]+)")))) (values nil "must match ^([a-z0-9]+)"))))
(defun cmd-create-account (r) (defun cmd-create-account (r)
(with-auth (with-auth
(with-n-args 1 r (with-n-args 1 r
@ -1026,6 +1080,7 @@
(make-response :code 200 :request r (make-response :code 200 :request r
:data (fmt "Okay, account ~a created with password ``~a''." :data (fmt "Okay, account ~a created with password ``~a''."
username pass-or-error))))))))) username pass-or-error)))))))))
(defun read-accounts! () (defun read-accounts! ()
(let ((*package* (find-package '#:loop))) (let ((*package* (find-package '#:loop)))
(with-open-file (with-open-file
@ -1056,6 +1111,7 @@
(push a *accounts*) (push a *accounts*)
(write-accounts!) (write-accounts!)
(values (str:upcase username) p))))) (values (str:upcase username) p)))))
(defun write-accounts! () (defun write-accounts! ()
(let ((name (let ((name
(loop (loop
@ -1078,6 +1134,7 @@
(loop for u in *accounts* (loop for u in *accounts*
do (when (string= (str:upcase username) (account-username u)) do (when (string= (str:upcase username) (account-username u))
(return u)))) (return u))))
(defun cmd-unlock-account (r) (defun cmd-unlock-account (r)
(with-auth (with-auth
(with-n-args 1 r (with-n-args 1 r
@ -1105,6 +1162,7 @@
(setf (account-pass u) (account-pass-locked u)) (setf (account-pass u) (account-pass-locked u))
(setf (account-pass-locked u) nil) (setf (account-pass-locked u) nil)
(setf (account-pass-locked-why u) nil))))) (setf (account-pass-locked-why u) nil)))))
(defun cmd-login (r) (defun cmd-login (r)
(let* ((args (mapcar #'str:upcase (request-args r)))) (let* ((args (mapcar #'str:upcase (request-args r))))
(cond (cond
@ -1123,6 +1181,7 @@
(defun log-user-in-as! (name) (defun log-user-in-as! (name)
(setf (client-username *client*) name) (setf (client-username *client*) name)
(log-user-in!)) (log-user-in!))
(defun cmd-passwd (r) (defun cmd-passwd (r)
(with-auth (with-auth
(let* ((args (mapcar #'str:upcase (request-args r)))) (let* ((args (mapcar #'str:upcase (request-args r))))
@ -1200,8 +1259,10 @@
(let ((u (get-account username))) (let ((u (get-account username)))
(if u (let ((s (account-seen u))) (if u (let ((s (account-seen u)))
(if s (universal-to-human s)))))) (if s (universal-to-human s))))))
(defun cmd-dd (r) (defun cmd-dd (r)
(make-response :code 200 :data (format nil "state: ~a" *client*) :request r)) (make-response :code 200 :data (format nil "state: ~a" *client*) :request r))
(defun cmd-repl (r) (defun cmd-repl (r)
(with-auth (with-auth
(repl r))) (repl r)))
@ -1268,6 +1329,7 @@
:description "logging (on stderr)" :description "logging (on stderr)"
:long-name "logging" :long-name "logging"
:key :logging))) :key :logging)))
(defun cli/list-accounts () (defun cli/list-accounts ()
(println (str:join (crlf-string) (list-users)))) (println (str:join (crlf-string) (list-users))))
@ -1297,6 +1359,7 @@
(if okay? (if okay?
(println "Okay, account ~a now has password ``~a''." username new-passwd) (println "Okay, account ~a now has password ``~a''." username new-passwd)
(println "Sorry, could not change password: ~a." problem)))))) (println "Sorry, could not change password: ~a." problem))))))
(defun cli/main-with-handlers (cmd) (defun cli/main-with-handlers (cmd)
(handler-case (handler-case
(cli/main cmd) (cli/main cmd)
@ -1333,7 +1396,7 @@
(clingon:make-command (clingon:make-command
:name "loop" :name "loop"
:description "An NNTP server for a circle of friends." :description "An NNTP server for a circle of friends."
:version "0.1" :version "9575ac2"
:license "GPL v3" :license "GPL v3"
:options (cli/options) :options (cli/options)
:handler #'cli/main-with-handlers)) :handler #'cli/main-with-handlers))
@ -1347,6 +1410,7 @@
(return)))))) (return))))))
(defun request-quit? (r) (and r (string= 'quit (request-verb r)))) (defun request-quit? (r) (and r (string= 'quit (request-verb r))))
(defun response-quit? (r) (and r (request-quit? (response-request r)))) (defun response-quit? (r) (and r (request-quit? (response-request r))))
(defun server-start () (defun server-start ()
@ -1360,7 +1424,9 @@
(defun send-banner! () (defun send-banner! ()
(send-response! (send-response!
(make-response :code 200 :data "Welcome! Say ``help'' for a menu."))) (make-response
:code 200
:data "Welcome! I am LOOP 9575ac2. Say ``help'' for a menu.")))
(setq lisp-unit:*print-failures* t) (setq lisp-unit:*print-failures* t)
(define-test first-test-of-the-west (define-test first-test-of-the-west

86
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 users need to know how to use {\tt nc} or {\tt telnet} to take
advantage of all of \lp's capabilities. advantage of all of \lp's capabilities.
\section{NNTP protocol} \section{NNTP protocol}
An Internet protocol is usually defined by a document whose tradition 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)))))))) (str:replace-all (string #\linefeed) " " (fmt "~a" c))))))))
@ %def repl @ %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} \section{Representation of a client}
How do we represent a client? A client is typically reading a group 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))) (write-sequence ls-of-bytes s)))
@ %def my-write @ %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} \section{Main loop}
Every command consumes a [[request]] and produces a [[response]]. If Every command consumes a [[request]] and produces a [[response]]. If
@ -657,9 +627,59 @@ itself---so we can cascade actions based on a user's request.
(defun send-banner! () (defun send-banner! ()
(send-response! (send-response!
(make-response :code 200 :data "Welcome! Say ``help'' for a menu."))) (make-response
:code 200
:data "<<Welcome message>>")))
@ %def main main-loop @ %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>>=
9575ac2
@
\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} \section{Parsing of command-line arguments}
We're using the clingon library as per Vincent Dardel suggestion in We're using the clingon library as per Vincent Dardel suggestion in
@ -2804,7 +2824,7 @@ The \lp\ system definition:
<<loop.asd>>= <<loop.asd>>=
;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*- ;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*-
(asdf:defsystem :loop (asdf:defsystem :<<Name>>
:version "<<Version>>" :version "<<Version>>"
:description "<<Description>>" :description "<<Description>>"
:depends-on (<<List of packages to be loaded>>) :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
}" $*