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

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)) && \

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)

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)
+                    (mapcar #'(lambda (h)
-                              (format nil "~a: ~a" (car h) (cdr 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)
+        (ngs-dont-exist))
-    (dolist (ng ngs)
+    (dolist (g ngs)
-      (if (and (group-name-conforms? ng)
+      (if (or (not (group-name-conforms? g))
-               (group? ng))
+              (not (group? g)))
-          (progn 
+          (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)))
+          (values 240 (data "Thank you! Your article has been saved.")))
-    (if (zerop (- (length ngs) (length ngs-dont-exist)))
+        (values 400 (data "Sorry. We did not post your article to any newsgroup because "
-        (values 400 "Sorry. There was not a single valid newsgroup specified.")
+                          "the " (word-plural (length ngs-dont-exist) "newsgroup") " " 
-        (values 240 (data "Thank you! Your article has been saved."
+                          (str:join ", " (sort ngs-dont-exist #'string<))
-                          (when ngs-dont-exist
+                          " just " (word-plural (length ngs-dont-exist) "doesn't") " exist.")))))
-                            (data " However, the groups "
+
-                                  (str:join ", " (sort ngs-dont-exist #'string<))
+(defun newsgroups-header->list (s)
-                                  " just don't exist.")))))))
+  (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)
+    (multiple-value-bind (okay? reason) (user-name-conforms? u)
-        (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))

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.
 @ 
 
 <<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)
+    (multiple-value-bind (okay? reason) (user-name-conforms? u)
-        (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,8 +1757,8 @@ 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))) 
+                                (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)
+        (ngs-dont-exist))
-    (dolist (ng ngs)
+    (dolist (g ngs)
-      (if (and (group-name-conforms? ng)
+      (if (or (not (group-name-conforms? g))
-               (group? ng))
+              (not (group? g)))
-          (progn 
+          (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)))
+          (values 240 (data "Thank you! Your article has been saved.")))
-    (if (zerop (- (length ngs) (length ngs-dont-exist)))
+        (values 400 (data "Sorry. We did not post your article to any newsgroup because "
-        (values 400 "Sorry. There was not a single valid newsgroup specified.")
+                          "the " (word-plural (length ngs-dont-exist) "newsgroup") " " 
-        (values 240 (data "Thank you! Your article has been saved."
+                          (str:join ", " (sort ngs-dont-exist #'string<))
-                          (when ngs-dont-exist
+                          " just " (word-plural (length ngs-dont-exist) "doesn't") " exist.")))))
-                            (data " However, the groups "
+
-                                  (str:join ", " (sort ngs-dont-exist #'string<))
+(defun newsgroups-header->list (s)
-                                  " just don't exist.")))))))
+  (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
+XXX: notice we parse the article again to extract information from it
-invalid groups.  We should not do that.  A user might only want to
+that we need during [[post]].  That's not only a waste of
-post at all if his message is cross-posted to a few groups.  A user
+time---because we already did that---, but it makes [[post]] a lot
-might easily mistype a group name.  The Right Thing here is more
+less generic.  Perhaps [[conforms?]] should return a data structure
-likely to stop posting completely with an error message telling the
+that contains all that [[post]] needs.  Then [[post]] consumes that
-user to either remove the invalid group of type it up properly.
+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
+for us to trust we can move forward without breaking important past
-the code.
+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)