diff --git a/Anyfile b/Anyfile index de15135..12585eb 100644 --- a/Anyfile +++ b/Anyfile @@ -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)) && \ diff --git a/loop.asd b/loop.asd index 84c7674..5d13b57 100644 --- a/loop.asd +++ b/loop.asd @@ -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) diff --git a/loop.lisp b/loop.lisp index 82a042a..a178897 100644 --- a/loop.lisp +++ b/loop.lisp @@ -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,8 +915,8 @@ (make-article :headers (str:join (crlf-string) - (mapcar (lambda (h) - (format nil "~a: ~a" (car h) (cdr 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)) - (progn + (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 " - (str:join ", " (sort ngs-dont-exist #'string<)) - " just don't exist."))))))) + (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 " (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: +Subject: test +Newsgroups: local.test + +Quickest test of the West. +")) + +(defvar a-bad-post (unix->nntp "From: root +Message-id: +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)) diff --git a/loop.nw b/loop.nw index 6da4f08..68523a3 100644 --- a/loop.nw +++ b/loop.nw @@ -110,7 +110,7 @@ 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''. +posted to these newsgroups 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 @@ -658,7 +658,7 @@ An NNTP server for a circle of friends. @ <>= -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 <
>"))) ((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. <>= (defun unparse-article (parsed) @@ -1756,8 +1757,8 @@ now, however, we have only these two to worry about. (make-article :headers (str:join (crlf-string) - (mapcar (lambda (h) - (format nil "~a: ~a" (car h) (cdr 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. <>= -(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]]. + +<>= (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 + (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 " - (str:join ", " (sort ngs-dont-exist #'string<)) - " just don't exist."))))))) + (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 " (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. <>= (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. + +<>= (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*]]. <>= (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: +Subject: test +Newsgroups: local.test + +Quickest test of the West. +")) + +(defvar a-bad-post (unix->nntp "From: root +Message-id: +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)