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

Doesn't post unless the article goes only to existing newsgroups.

Browse source
This commit is contained in:
Circling Skies 2024-12-20 13:35:37 -03:00
parent 77c411756d
commit afe7d0e809
4 changed files with 220 additions and 105 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
Anyfile
View file

@ -13,13 +13,15 @@ loop.exe: scripts/build-exe.lisp loop.lisp loop.asd
(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
release:
./make-release $$(git log --oneline | head -1 | awk '{print $$1}') \
loop.nw > loop.tmp && mv loop.tmp loop.nw
loop.asd: loop.nw
(any tangle -Rloop.asd < loop.nw | dos2unix > loop-asd.tmp || \
(rm loop-asd.tmp && exit 1)) && \

2
loop.asd
View file

@ -1,6 +1,6 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*-
(asdf:defsystem :LOOP
:version "3719590"
:version "77c4117"
: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)

117
loop.lisp
View file

@ -9,7 +9,7 @@
(defpackage #:loop
(:use :common-lisp :local-time)
(:import-from :lisp-unit define-test)
(:import-from :lisp-unit define-test assert-true)
(:import-from :org.shirakumo.filesystem-utils
directory-p list-directories list-files)
(:import-from :sb-sys interactive-interrupt)
@ -92,7 +92,7 @@
(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)))
`(in-group-lambda ,(fmt "groups/~a/" g) #'(lambda () ,@body)))
(defmacro with-group (g r &rest body)
(let ((g-var (gensym))
@ -137,6 +137,13 @@
(apply #'format (cons t args))
(finish-output))
(defun word-plural (n word)
(let ((table '(("doesn't" . "don't")
("newsgroup" . "newsgroups"))))
(let ((w (assoc word table :test #'string=)))
(when (not w) (error "word not found"))
(if (< n 2) (car w) (cdr w)))))
(defun plural (v suffix)
(if (> v 1) suffix ""))
@ -190,7 +197,8 @@
(node result))
((null node) (delete nil result))
(cond ((consp (car node))
(when (cdar node) (push (cdar node) (cdr node)))
(when (cdar node) (push
(cdar node) (cdr node)))
(setf (car node) (caar node)))
(t (setf node (cdr node))))))
@ -701,7 +709,7 @@
(defun group? (g)
(in-groups
(directory-p g)))
(ignore-errors (directory-p g))))
(defun xgroup? (g)
(directory-p g))
@ -907,7 +915,7 @@
(make-article
:headers
(str:join (crlf-string)
(mapcar (lambda (h)
(mapcar #'(lambda (h)
(format nil "~a: ~a" (car h) (cdr h)))
(cons (cons h (funcall fn)) headers)))
:body (article-body (parse-article bs)))))))
@ -925,9 +933,6 @@
(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!
@ -947,22 +952,25 @@
(get-header "newsgroups" (parse-headers
(article-headers
(parse-article bs))))))
ngs-dont-exist)
(dolist (ng ngs)
(if (and (group-name-conforms? ng)
(group? ng))
(ngs-dont-exist))
(dolist (g ngs)
(if (or (not (group-name-conforms? g))
(not (group? g)))
(push g ngs-dont-exist)))
(if (zerop (length ngs-dont-exist))
(progn
(dolist (ng ngs)
(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 "
(values 240 (data "Thank you! Your article has been saved.")))
(values 400 (data "Sorry. We did not post your article to any newsgroup because "
"the " (word-plural (length ngs-dont-exist) "newsgroup") " "
(str:join ", " (sort ngs-dont-exist #'string<))
" just don't exist.")))))))
" just " (word-plural (length ngs-dont-exist) "doesn't") " exist.")))))
(defun newsgroups-header->list (s)
(mapcar #'(lambda (n) (str:trim (string-downcase n))) (str:split "," s)))
(defun update-last-post-date! (username)
(let ((u (get-account username)))
@ -1035,7 +1043,7 @@
(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))
(mapcar #'(lambda (ls) (append ls (list 13 10))) ls-of-ls))
(defun string->bytes (s)
(map 'list #'char-code s))
@ -1110,8 +1118,8 @@
(a (make-account :username u
:pass (string->sha256 (str:upcase p))
:creation (get-universal-time))))
(multiple-value-bind (okay? reason)
(user-name-conforms? u)
(multiple-value-bind (okay? reason) (user-name-conforms? u)
(declare (ignore reason))
(cond ((not okay?)
(values nil (fmt "username must conform to ^[^\\s]+$")))
((get-account u)
@ -1215,7 +1223,8 @@
(let ((u (get-account username)))
(and
u
(cond ((integerp (account-pass u))
(cond ((null (account-pass u)) nil)
((integerp (account-pass u))
(eq (sxhash pass) (account-pass u)))
((arrayp (account-pass u))
(equalp (string->sha256 pass) (account-pass u)))
@ -1242,7 +1251,7 @@
(defun list-users ()
(read-accounts!)
(mapcar (lambda (row) (cadr row))
(mapcar #'(lambda (row) (cadr row))
(sort
(loop for u in *accounts*
collect (list (account-username u)
@ -1257,7 +1266,7 @@
(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)))))
#'string<= :key #'(lambda (row) (car row)))))
(defun universal-to-human (s)
(format-timestring
@ -1304,7 +1313,7 @@
:headers (data
(add-crlf-between
(mapcar
(lambda (p) (data (format nil "~a: ~a" (car p) (cdr p))))
#'(lambda (p) (data (format nil "~a: ~a" (car p) (cdr p))))
`(("from" . "Loop")
("subject" . ,subject)
("newsgroups" . "local.control.news")))))
@ -1405,7 +1414,7 @@
(clingon:make-command
:name "loop"
:description "An NNTP server for a circle of friends."
:version "3719590"
:version "77c4117"
:license "GPL v3"
:options (cli/options)
:handler #'cli/main-with-handlers))
@ -1435,23 +1444,43 @@
(send-response!
(make-response
:code 200
:data "Welcome! I am LOOP 3719590. Say ``help'' for a menu.")))
:data "Welcome! I am LOOP 77c4117. Say ``help'' for a menu.")))
(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)))))
(assert-true (equalp (empty-response) (dispatch (make-request)))))
(defun unix->nntp (s)
"I substitute \n for \r\n"
(str:replace-all (fmt "~a" #\linefeed) (crlf-string) s))
(defvar a-post (unix->nntp "From: root
Message-id: <pwtdldytefplntosymvo@loop>
Subject: test
Newsgroups: local.test
Quickest test of the West.
"))
(defvar a-bad-post (unix->nntp "From: root
Message-id: <pwtdldytefplntosymvp@loop>
Subject: a bad test
Newsgroups: local.test, bad.newsgroup
A bad test from the biggest mouth of the south.
"))
(define-test post-wrong-newsgroup
(multiple-value-bind (code msg) (post (string->bytes a-bad-post))
(declare (ignore msg))
(assert-true (equal code 400))))
(define-test post-okay
(read-accounts!)
(connect-index! "test.db")
(create-index!)
(setq *client* (make-client :username "ROOT" :auth? 'yes))
(multiple-value-bind (code msg) (post (string->bytes a-post))
(declare (ignore msg))
(assert-true (equal code 240)))
(clsql:disconnect))

186
loop.nw
View file

@ -658,7 +658,7 @@ An NNTP server for a circle of friends.
@
<<Version>>=
3719590
77c4117
@
\section{Parsing of requests}
@ -1109,8 +1109,8 @@ it's their problem.
(a (make-account :username u
:pass (string->sha256 (str:upcase p))
:creation (get-universal-time))))
(multiple-value-bind (okay? reason)
(user-name-conforms? u)
(multiple-value-bind (okay? reason) (user-name-conforms? u)
(declare (ignore reason))
(cond ((not okay?)
(values nil (fmt "username must conform to <<Form of user names>>")))
((get-account u)
@ -1249,7 +1249,8 @@ there is a macro emerging here called [[with-upcase-args]]. %% TODO
(let ((u (get-account username)))
(and
u
(cond ((integerp (account-pass u))
(cond ((null (account-pass u)) nil)
((integerp (account-pass u))
(eq (sxhash pass) (account-pass u)))
((arrayp (account-pass u))
(equalp (string->sha256 pass) (account-pass u)))
@ -1284,7 +1285,7 @@ invited who.
(defun list-users ()
(read-accounts!)
(mapcar (lambda (row) (cadr row))
(mapcar #'(lambda (row) (cadr row))
(sort
(loop for u in *accounts*
collect (list (account-username u)
@ -1299,7 +1300,7 @@ invited who.
(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)))))
#'string<= :key #'(lambda (row) (car row)))))
(defun universal-to-human (s)
(format-timestring
@ -1483,7 +1484,7 @@ We just need to verify if the group exists and modify [[*client*]].
(defun group? (g)
(in-groups
(directory-p g)))
(ignore-errors (directory-p g))))
(defun xgroup? (g)
(directory-p g))
@ -1728,7 +1729,7 @@ must have \verb|message-id|, \verb|subject|, \verb|from|,
@
Sometimes we parse an article and sometimes we want to undo that
parsing. Am I doing something wrong? I wonder. %% TODO
parsing. Am I doing something wrong? I wonder.
<<Command post>>=
(defun unparse-article (parsed)
@ -1756,7 +1757,7 @@ now, however, we have only these two to worry about.
(make-article
:headers
(str:join (crlf-string)
(mapcar (lambda (h)
(mapcar #'(lambda (h)
(format nil "~a: ~a" (car h) (cdr h)))
(cons (cons h (funcall fn)) headers)))
:body (article-body (parse-article bs)))))))
@ -1797,9 +1798,6 @@ 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)
(mapcar (lambda (n) (str:trim (string-downcase n))) (str:split "," s)))
(defun cmd-post (r)
(with-auth
(send-response!
@ -1813,36 +1811,60 @@ of trying to stop them.
: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)))))))
@
It's time to write the action of posting. One thing to keep in mind
is cross-posting. First, notice that we're---so far---duplicating
articles on the file system. (We will undo that once we reimplement
our index. More to follow.) More importantly, we cannot let the user
post to any group if one of the groups is incorrectly named---for
example, when the group doesn't exist. Why don't we post to the ones
that are correct and warn the user of the ones that are incorrect?
Because that is not prudent. The user could be trying to divulge news
to be received at the same time by various groups. We would make such
plans all go down the drain. So we don't.
We collect a list of newsgroups that don't exist (or whose names do
not conform for any reason). If we find any such group, then we
refuse posting and return a 400 code with a message describing which
group names failed. Otherwise we [[save-article-insist]].
<<Command post>>=
(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))
(ngs-dont-exist))
(dolist (g ngs)
(if (or (not (group-name-conforms? g))
(not (group? g)))
(push g ngs-dont-exist)))
(if (zerop (length ngs-dont-exist))
(progn
(dolist (ng ngs)
(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 "
(values 240 (data "Thank you! Your article has been saved.")))
(values 400 (data "Sorry. We did not post your article to any newsgroup because "
"the " (word-plural (length ngs-dont-exist) "newsgroup") " "
(str:join ", " (sort ngs-dont-exist #'string<))
" just don't exist.")))))))
" just " (word-plural (length ngs-dont-exist) "doesn't") " exist.")))))
(defun newsgroups-header->list (s)
(mapcar #'(lambda (n) (str:trim (string-downcase n))) (str:split "," s)))
@ %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.
XXX: notice we parse the article again to extract information from it
that we need during [[post]]. That's not only a waste of
time---because we already did that---, but it makes [[post]] a lot
less generic. Perhaps [[conforms?]] should return a data structure
that contains all that [[post]] needs. Then [[post]] consumes that
and saves the article more easily. That's a better idea. I think
[[post]] should not even use variables such as [[*client*]]. The
username to which to update the last-seen date should be included in
the data structure.
<<Command post>>=
(defun update-last-post-date! (username)
@ -1960,7 +1982,7 @@ never comes from the NNTP protocol because there's is always a {\tt
(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))
(mapcar #'(lambda (ls) (append ls (list 13 10))) ls-of-ls))
(defun string->bytes (s)
(map 'list #'char-code s))
@ -2118,7 +2140,7 @@ invitations {\em et cetera} are published there.
:headers (data
(add-crlf-between
(mapcar
(lambda (p) (data (format nil "~a: ~a" (car p) (cdr p))))
#'(lambda (p) (data (format nil "~a: ~a" (car p) (cdr p))))
`(("from" . "Loop")
("subject" . ,subject)
("newsgroups" . "local.control.news")))))
@ -2544,13 +2566,22 @@ example, when we need to access the group database, we use
`(let ((*default-pathname-defaults* (truename ,dir)))
(uiop:with-current-directory (,dir)
,@body)))
@
Notice that we set [[*default-pathname-defaults*]] and we set the
process' current working directory. That's not necessary because Lisp
always uses [[*default-pathname-defaults*]] and does not care about
the current working directory. We did this out of the fact that we
used to invoke [[renameat2]] through the [[cffi]], but we don't use it
any more.
<<Macros>>=
(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)))
`(in-group-lambda ,(fmt "groups/~a/" g) #'(lambda () ,@body)))
(defmacro with-group (g r &rest body)
(let ((g-var (gensym))
@ -2608,6 +2639,13 @@ means 2 bytes. So our conversion is just removing the first byte.
(apply #'format (cons t args))
(finish-output))
(defun word-plural (n word)
(let ((table '(("doesn't" . "don't")
("newsgroup" . "newsgroups"))))
(let ((w (assoc word table :test #'string=)))
(when (not w) (error "word not found"))
(if (< n 2) (car w) (cdr w)))))
(defun plural (v suffix)
(if (> v 1) suffix ""))
@ -2673,30 +2711,76 @@ means 2 bytes. So our conversion is just removing the first byte.
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.
for us to trust we can move forward without breaking important past
decisions in the code. XXX: we should not include these tests in
production code as we are doing right now. Divert them to a tests
package or something that makes more sense. To run the tests, you
need to invoke [[lisp-unit:run-tests]]. I believe that invoking it in
a script will make all tests run. Oh, that should be included the
binary, too, so that we can always test an archived project. That's a
good idea. Make it a clingon option on the command line. Of course,
by including tests in the executable, we should isolate all the tests
here. I know how---just define a test package and isolate it all in
it. Packages are for namespace isolation. Lisp's ``systems'' are the
type of packaging meant for loading. Lisp's ``packages'' are merely
namespace isolation. Our test package should use \lp's package, so
that we can use any of the procedures under testing. When we define a
variable, it will be defined in the test package, not in \lp's, but
when we are in \lp's package, we see no names of the test package.
It's simple and a good solution.
When testing, it's important for us not to clutter a production
system---we will want to run tests on production systems. So what we
need to do is to wrap any file system modification to a certain other
directory in which \lp's tests will find the groups directory in
place. Making that happen is as simple as changing
[[*default-pathname-defaults*]].
<<Test procedures>>=
(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)))))
(assert-true (equalp (empty-response) (dispatch (make-request)))))
(defun unix->nntp (s)
"I substitute \n for \r\n"
(str:replace-all (fmt "~a" #\linefeed) (crlf-string) s))
(defvar a-post (unix->nntp "From: root
Message-id: <pwtdldytefplntosymvo@loop>
Subject: test
Newsgroups: local.test
Quickest test of the West.
"))
(defvar a-bad-post (unix->nntp "From: root
Message-id: <pwtdldytefplntosymvp@loop>
Subject: a bad test
Newsgroups: local.test, bad.newsgroup
A bad test from the biggest mouth of the south.
"))
(define-test post-wrong-newsgroup
(multiple-value-bind (code msg) (post (string->bytes a-bad-post))
(declare (ignore msg))
(assert-true (equal code 400))))
(define-test post-okay
(read-accounts!)
(connect-index! "test.db")
(create-index!)
(setq *client* (make-client :username "ROOT" :auth? 'yes))
(multiple-value-bind (code msg) (post (string->bytes a-post))
(declare (ignore msg))
(assert-true (equal code 240)))
(clsql:disconnect))
@ %def
XXX: we got a problem with test [[post-okay]]. We're getting an
execution error, but we can't see any error message. The posting is
taking place---here in the REPL at least.
\section{How to produce the binary executable}
Just say {\tt make loop} to your shell.
@ -2781,7 +2865,7 @@ something to think about.
(defpackage #:loop
(:use :common-lisp :local-time)
(:import-from :lisp-unit define-test)
(:import-from :lisp-unit define-test assert-true)
(:import-from :org.shirakumo.filesystem-utils
directory-p list-directories list-files)
(:import-from :sb-sys interactive-interrupt)