Give up on using catch and use conditions instead.

This is a major rewrite of how we're catching for trouble during
parsing and the posting of articles.  When fetching articles by
message-id, we don't need to enforce that a group has been chosen.

loop.lisp

@@ -45,6 +45,10 @@
     ("NEXT" ,#'cmd-next "increments the article pointer")
     ("HELP" ,#'cmd-help "displays this menu")
     ("LIST" ,#'cmd-list "lists all groups")
+    ("LIST NEWSGROUPS" ,#'cmd-list "same as LIST")
+    ("LIST ACTIVE" ,#'cmd-list "same as LIST")
+    ("LIST OVERVIEW.FMT" ,#'cmd-list "lists xover fields")
+    ("CAPABILITIES" ,#'cmd-capabilities "displays our capabilities")
     ("AUTHINFO" ,#'cmd-authinfo "makes me trust you")
     ("LOGIN" ,#'cmd-login "shorter interface to AUTHINFO")
     ("HEAD" ,#'cmd-head "fetches article headers")
@@ -53,6 +57,7 @@
     ("POST" ,#'cmd-post "posts your article")
     ("ARTICLE" ,#'cmd-article "fetches full articles")
     ("XOVER" ,#'cmd-xover "fetches the overview database of a group")
+    ("XHDR" ,#'cmd-xhdr "fetches a specific header from articles")
     ("CREATE-GROUP" ,#'cmd-create-group 
                     "creates a new group so you can discuss your favorite topic")
     ("CREATE-ACCOUNT",#'cmd-create-account 
@@ -411,15 +416,22 @@
 
 (defun hs-lines (lines) (str:split (crlf-string) lines))
 
+(define-condition article-syntax-error (error)
+  ((message :initarg :message :reader article-syntax-error-message))
+  (:report (lambda (condition stream)
+             (format stream "~a" (article-syntax-error-message condition)))))
+
+(defun article-syntax-error! (fmt-str &rest args)
+  (error 'article-syntax-error
+         :message (apply #'fmt fmt-str args)))
+
 (defun parse-header (header)
   (let* ((h (str:collapse-whitespaces header))
          (pos (search ":" h)))
     (when (null pos)
-      (throw 'article-syntax-error
+      (article-syntax-error! (fmt "missing colon in header |~a|" h)))
-        (values nil (fmt "missing colon in header |~a|" h))))
     (when (<= (length h) (+ 2 pos))
-      (throw 'article-syntax-error
+      (article-syntax-error! (fmt "empty header ~a" h)))
-        (values nil (fmt "empty header ~a" h))))
     (multiple-value-bind (key val)
         (values (subseq h 0 pos) (subseq h (+ 2 pos)))
       (cons (str:downcase key) val))))
@@ -559,6 +571,22 @@
 (defun dispatch-line (ln)
   (dispatch (parse-request (make-request :said ln))))
 
+(defun cmd-capabilities (r)
+  (prepend-response-with
+   "We are very capable! Please, take note:"
+   (make-response
+    :code 101 :multi-line 'yes :request r
+    :data (str:join (crlf-string) (capabilities-lines)))))
+
+(defun capabilities-lines ()
+  (append
+   (list "VERSION 2"
+         "READER")
+   (when (auth?) (list "POST"))
+   (list "AUTHINFO USER"
+         "LIST ACTIVE NEWSGROUPS OVERVIEW.FMT"
+         (fmt "IMPLEMENTATION LOOP ~a" *git-hash*))))
+
 (defun cmd-authinfo (r) 
   (let* ((args (mapcar #'str:upcase (request-args r))))
     (cond 
@@ -596,30 +624,28 @@
 (defun cmd-mode (r) ;; Whatever.
   (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-by-number fn-by-mid)
   (with-auth
-      (with-group-set
+      (let ((args (request-args r)))
-          (let ((args (request-args r)))
+        (cond ((null args)
-            (cond ((null args)
+               (with-group-set
-                   (funcall fn-name r (client-group *client*) (client-article *client*)))
+                   (funcall fn-by-number r (client-group *client*) (client-article *client*))))
-                  ((= 1 (length args))
+              ((= 1 (length args))
-                   (let* ((n-or-mid (car args)))
+               (let* ((n-or-mid (car args)))
-                     (cond ((string-integer? n-or-mid) 
+                 (cond ((string-integer? n-or-mid)
-                            (funcall fn-name r (client-group *client*) n-or-mid))
+                        (with-group-set
-                           (t (multiple-value-bind (group n-str) (lookup-index n-or-mid)
+                            (funcall fn-by-number r (client-group *client*) n-or-mid)))
-                                (if (and group n-str)
+                       (t (funcall fn-by-mid r n-or-mid)))))
-                                    (funcall fn-name r group n-str)
+              (t (bad-input r "No, no: it takes at most two arguments."))))))
-                                    (bad-input r (fmt "Unknown article ~a." n-or-mid))))))))
-                  (t (bad-input r "No, no: it takes at most two arguments.")))))))
 
 (defun cmd-head (r)
-  (typical-cmd-head-body-article r #'head-response))
+  (typical-cmd-head-body-article r #'head-response #'head-response-by-mid))
 
 (defun cmd-body (r)
-  (typical-cmd-head-body-article r #'body-response))
+  (typical-cmd-head-body-article r #'body-response #'body-response-by-mid))
 
 (defun cmd-article (r)
-  (typical-cmd-head-body-article r #'article-response))
+  (typical-cmd-head-body-article r #'article-response #'article-response-by-mid))
 
 (defun article-response (r g i)
   (typical-cmd-response 220 r g i :article))
@@ -630,12 +656,21 @@
 (defun body-response (r g i)
   (typical-cmd-response 222 r g i :body))
 
-(defun typical-cmd-response (code r g i requested-part)
+(defun article-response-by-mid (r mid)
+  (typical-cmd-response-by-mid 220 r mid :article))
+
+(defun head-response-by-mid (r mid)
+  (typical-cmd-response-by-mid 221 r mid :head))
+
+(defun body-response-by-mid (r mid)
+  (typical-cmd-response-by-mid 222 r mid :body))
+
+(defun typical-cmd-response-at-path (code r path error-label response-number requested-part
+                                     &optional (not-found-code 400))
   (handler-case
-      (let* ((path (fmt "groups/~a/~a" g i))
+      (let* ((headers-raw (read-headers-raw path)))
-             (headers-raw (read-headers-raw path)))
         (if (null headers-raw)
-            (make-response :code 400 :request r :data (fmt "article ~a/~a does not exist" g i))
+            (make-response :code 400 :request r :data (fmt "article ~a does not exist" error-label))
             (let* ((a (parse-article headers-raw))
                    (mid (extract-mid headers-raw))
                    (head-length (length headers-raw))
@@ -648,19 +683,35 @@
                                        (crlf) (crlf)
                                        (make-file-stream-payload :path path
                                                                  :start-pos body-start))))))
-              (prepend-response-with (fmt "~a ~a" i mid)
+              (prepend-response-with (fmt "~a ~a" response-number mid)
                                      (make-response :multi-line 'yes :code code
                                                     :request r :data payload)))))
-    
+    (file-error (c)
+      (declare (ignore c))
+      (make-response :code not-found-code :request r
+                     :data (fmt "Sorry, no such article ~a." error-label)))
     (sb-posix:syscall-error (c)
-      (let ((msg (fmt "article ~a/~a: ~a" g i c)))
+      (let ((msg (fmt "article ~a: ~a" error-label c)))
         (stderr msg)
         (make-response :code 400 :request r :data msg)))
     (error (c)
-      (let ((msg (fmt "unexpected condition when reading article ~a/~a: ~a" g i c)))
+      (let ((msg (fmt "sorry ~a: ~a" error-label c)))
         (stderr msg)
         (make-response :code 400 :request r :data msg)))))
 
+(defun typical-cmd-response (code r g i requested-part)
+  (typical-cmd-response-at-path
+   code r
+   (fmt "groups/~a/~a" g i)
+   (fmt "~a/~a" g i) i requested-part 423))
+
+(defun typical-cmd-response-by-mid (code r mid requested-part)
+  (typical-cmd-response-at-path
+   code r
+   (index-path (index-hash mid))
+   mid
+   0 requested-part 400))
+
 (defun cmd-next (r)
   (with-auth
       (let ((g (client-group *client*))
@@ -732,6 +783,74 @@
 (defun xover-headers ()
   '("subject" "from" "date" "message-id" "references" "line-count" "byte-count"))
 
+(defun cmd-xhdr (r)
+  (with-auth
+      (with-group-set
+          (let ((args (request-args r)))
+            (cond
+              ((or (null args) (> (length args) 2))
+               (make-response :code 502 :request r
+                              :data "bad syntax: usage is XHDR header [range|message-id]"))
+              (t
+               (let ((header (string-downcase (car args)))
+                     (range-arg (cadr args)))
+                 (cond
+                   ((null range-arg)
+                    (xhdr r header (client-article *client*) (client-article *client*)))
+                   ((message-id-syntax? range-arg)
+                    (xhdr-by-message-id r header range-arg))
+                   (t
+                    (multiple-value-bind (fr to) (parse-range range-arg)
+                      (if (not fr)
+                          (make-response :code 502 :request r :data "bad syntax")
+                          (xhdr r header fr to))))))))))))
+
+(defun message-id-syntax? (s)
+  (and (> (length s) 0) (char= (char s 0) #\<)))
+
+(defun parse-range (s)
+  "Parses S of the form N, N-, or N-M. Returns (values from to), or
+   (values nil nil) when S doesn't conform."
+  (multiple-value-bind (matched v) (cl-ppcre:scan-to-strings "([0-9]+)([-]?)([0-9]*)" s)
+    (if (not matched)
+        (values nil nil)
+        (let ((fr (parse-integer (aref v 0)))
+              (hifen (aref v 1))
+              (to (ignore-errors (parse-integer (aref v 2)))))
+          (values fr (if (string= hifen "-") to fr))))))
+
+(defun xhdr (r header from to)
+  (assert (client-group *client*))
+  (let* ((g (client-group *client*))
+         (ls (get-articles g from to)))
+    (cond ((= 0 (length ls))
+           (make-response :code 420 :request r :data "no articles in the range"))
+          (t
+           (prepend-response-with
+            (fmt "~a header follows" header)
+            (make-response
+             :code 221 :request r :multi-line 'yes
+             :data (str:join
+                    (crlf-string)
+                    (loop for i in ls
+                          collect (xhdr-format-line i (get-header header (fetch-headers g i)))))))))))
+
+(defun xhdr-by-message-id (r header mid)
+  (multiple-value-bind (g n) (lookup-by-message-id mid)
+    (if (not (and g n))
+        (make-response :code 430 :request r :data "no such article")
+        (handler-case
+            (prepend-response-with
+             (fmt "~a header follows" header)
+             (make-response :code 221 :request r :multi-line 'yes
+                            :data (xhdr-format-line 0 (get-header header (fetch-headers g n)))))
+          (error (c)
+            (declare (ignore c))
+            (make-response :code 430 :request r :data "no such article"))))))
+
+(defun xhdr-format-line (i value)
+  (fmt "~a ~a" i value))
+
 (defun cmd-group (r)
   (with-auth
       (with-n-args 1 r
@@ -752,12 +871,39 @@
 (defstruct group name high low)
 
 (defun cmd-list (r)
+  (let* ((args (request-args r))
+         (keyw (and (= 1 (length args)) (car args))))
+    (cond
+      ((or (null args) (member keyw '("NEWSGROUPS" "ACTIVE") :test #'string-equal))
+       (list-groups-response r))
+       ((and keyw (string-equal keyw "OVERVIEW.FMT"))
+        (list-overview-fmt-response r))
+       (t (make-response :code 503 :request r
+                         :data (fmt "Unsupported LIST variant ``~a''." (str:join " " args)))))))
+
+(defun list-groups-response (r)
   (prepend-response-with 
    "Get in the loop! Lots to choose from."
    (make-response :code 215 :multi-line 'yes
                   :data (str:join (crlf-string) (build-groups-lines (build-groups-structs)))
                   :request r)))
 
+(defun list-overview-fmt-response (r)
+  (prepend-response-with
+   "What to expect in XOVER? These."
+   (make-response :code 215 :multi-line 'yes
+                  :data (str:join (crlf-string) (overview-fmt-lines))
+                  :request r)))
+
+(defun overview-fmt-lines ()
+  '("From:"
+    "Date:"
+    "Message-ID:"
+    "References:"
+    "Bytes:"
+    "Lines:"
+    "Xref:full"))
+
 (defun build-groups-lines (ls)
   (reverse
    (mapcar 
@@ -954,34 +1100,31 @@
                  :data 
                  (nntp-date-command)))
 
-(defun conforms? (bs)
-  (catch 'article-syntax-error
-    (conforms-headers?
-     (article-head (parse-article bs)))))
-
 (defun conforms-headers? (headers-str)
   "HEADERS-STR is the raw header block (without the body).
    Returns (values T NIL) on success, or (values NIL error-string)."
-  (catch 'article-syntax-error
+  (let* ((headers (parse-headers headers-str))
-    (let ((headers (parse-headers headers-str)))
+         (missing (loop for h in (headers-required-from-clients)
-      (let ((result (dolist (h (headers-required-from-clients))
+                        unless (lookup h headers)
-                      (when (not (lookup h headers))
+                        collect h)))
-                        (return (fmt "missing the /~a/ header" h))))))
+    (cond
-        (cond
+      (missing (article-syntax-error!
-          ((stringp result) (values nil result))
+                (fmt "missing the ~a ~a"
-          (t
+                     (str:join ", " (mapcar (lambda (h) (fmt "/~a/" h)) missing))
-           (let ((ngs (newsgroups-header->list (get-header "newsgroups" headers)))
+                     (word-plural (length missing) "header"))))
-                 (ngs-dont-exist nil))
+      (t
-             (dolist (g ngs)
+       (let ((ngs (newsgroups-header->list (get-header "newsgroups" headers)))
-               (when (or (not (group-name-conforms? g))
+             (ngs-dont-exist nil))
-                         (not (group? g)))
+         (dolist (g ngs)
-                 (push g ngs-dont-exist)))
+           (when (or (not (group-name-conforms? g))
-             (if (not (zerop (length ngs-dont-exist)))
+                     (not (group? g)))
-                 (values nil (fmt "the ~a ~a just ~a exist"
+             (push g ngs-dont-exist)))
-                                     (word-plural (length ngs-dont-exist) "newsgroup")
+         (if (not (zerop (length ngs-dont-exist)))
-                                     (str:join ", " (sort ngs-dont-exist #'string<))
+             (article-syntax-error! (fmt "the ~a ~a just ~a exist"
-                                     (word-plural (length ngs-dont-exist) "doesn't")))
+                                         (word-plural (length ngs-dont-exist) "newsgroup")
-                 (values t nil)))))))))
+                                         (str:join ", " (sort ngs-dont-exist #'string<))
+                                         (word-plural (length ngs-dont-exist) "doesn't")))
+             (values t nil)))))))
 
 (defun text/plain? (header-s)
   ;; I say T when S begins with "text/plain" or when S is "".
@@ -1009,44 +1152,38 @@
 
 (defun cmd-post (r)
   (with-auth
-      (let ((suggested (suggest-message-id)))
+      (send-response!
-        (send-response!
+       (make-response :code 340
-         (make-response
+                      :data (fmt "Okay, go ahead. Suggested message-id ~a." (suggest-message-id))))
-          :code 340
+    (let ((tmp (fmt "tmp/post-~a.tmp" (random-string 12))))
-          :data (fmt "Okay, go ahead. Suggested message-id ~a." suggested)))
+      (unwind-protect
-        (let ((tmp (fmt "tmp/post-~a.tmp" (random-string 12))))
+           (handler-case
-          (unwind-protect
                (progn
                  (nntp-read-article-to-disk tmp)
-                 (stderr "finished writing article to disk in tmp/~a~%" tmp)
+                 (stderr "finished writing article to disk in ~a~%" tmp)
                  (let* ((headers-raw (read-headers-raw tmp))
-                        ;; headers-raw includes the terminating CRLF CRLF; strip it
-                        ;; so parse-headers does not see an empty final line.
                         (headers-str (bytes->string headers-raw))
                         (hds (parse-headers headers-str))
                         (mid (get-header "message-id" hds))
                         (ngs (newsgroups-header->list (get-header "newsgroups" hds))))
                    (stderr "finished reading the headers of the tmp file~%")
                    (stderr "headers string: ~a~%" headers-str)
-                   (multiple-value-bind (okay? error) (conforms-headers? headers-str)
+                   (conforms-headers? headers-str) ;; raises a condition if it doesn't go well
-                     (cond
+                   (let* ((hash (store-article-in-index! tmp mid)))
-                       ((not okay?)
+                     (stderr "stored ~a from ~a~%" hash mid)
-                        (make-response
+                     (dolist (ng ngs)
+                       (let ((new-id (link-article-into-group-insist! hash ng (get-next-article-id ng))))
+                         (update-group-meta-incremental! ng new-id)))
+                     (stderr "linking finished~%")
+                     (update-last-post-date! (client-username *client*))
+                     (make-response :code 240 :request r :data "Thank you! Your article has been saved."))))
+             (article-syntax-error (c)
+               (make-response
                          :code 400 :request r
-                         :data (fmt "Sorry. Your article doesn't conform: ~a." error)))
+                         :data (fmt "Sorry. Your article doesn't conform: ~a." c)))
-                       (t
+             (already-seen-article (c)
-                        (handler-case
+               (make-response :code 441 :request r :data (fmt "~a" c))))
-                            (let* ((hash (store-article-in-index! tmp mid)))
+        (ignore-errors (delete-file tmp))))))
-                              (stderr "stored ~a from ~a~%" hash mid)
-                              (dolist (ng ngs)
-                                (let ((new-id (link-article-into-group-insist! hash ng (get-next-article-id ng))))
-                                  (update-group-meta-incremental! ng new-id)))
-                              (stderr "Procedure post has finished.~%")
-                              (update-last-post-date! (client-username *client*))
-                              (make-response :code 240 :request r :data "Thank you! Your article has been saved."))
-                          (already-seen-article (c)
-                            (make-response :code 441 :request r :data (fmt "~a" c)))))))))
-            (ignore-errors (delete-file tmp)))))))
 
 (defun newsgroups-header->list (s)
   (mapcar #'(lambda (n) (str:trim (string-downcase n))) (str:split "," s)))
@@ -1059,40 +1196,6 @@
   (rename-file (merge-pathnames old (uiop:getcwd)) 
                (merge-pathnames (make-pathname :name new :type :unspecific) (uiop:getcwd))))
 
-(defun save-article-try-old (g name-try tmp-path)
-  (stderr "going to try to save ~a with name ~a/~a~%" tmp-path g name-try)
-  (let ((name (fmt "~a" name-try))
-        (tmp  (fmt "~a.tmp" name-try)))
-    (with-open-file
-        (s name
-           :direction :output
-           :if-exists nil ; atomic O_EXCL allocation
-           :if-does-not-exist :create)
-      (when (null s)
-        (stderr "warning: save-article-try: ~a exists~%" name)
-        (return-from save-article-try-old 'name-exists)))
-    (stderr "going to rename in save-article-try~%")
-    ;; We've been called to save tmp-path to its permanent name. We're
-    ;; merely going to rename it there. So the rename call is now
-    ;; tmp/post-tmpfile.tmp to index/bb/bb/hash. To get the hash we
-    ;; need need the message-id.
-
-    (stderr "current-directory: ~a~%" (uiop:getcwd))
-    (stderr "default-pathname: ~a~%" *default-pathname-defaults*)
-                                        ;(stderr "rename-no-extension ~a ~a~%" (fmt "~a" tmp-path) (fmt "~a" name))
-
-    ;; The call to rename-no-extension must be at the root, so I can't
-    ;; localize my life using in-group or in-groups here.  Leaving it
-    ;; like that.
-    ;;(rename-no-extension (fmt "~a" tmp-path) (fmt "groups/~a/~a" g name))
-
-    ;; We don't call rename here any longer.  The article is now
-    ;; safely written to tmp and it's time to store it at its
-    ;; permanent path, which is computed by store-article-in-index!
-    ;; So go ahead and do that.  But we need the MID now!  Delegated
-    ;; it to the index itself.  (Notice we don't need G here anymore.)
-    (store-article-in-index! tmp-path)))
-
 (defun save-article-insist-old (g name src-path)
   (loop for name from name do
     (when (not (eql 'name-exists (save-article-try-old g name src-path)))

loop.nw

@@ -477,6 +477,10 @@ commands, which is essentially what the user sees when asks for
     ("NEXT" ,#'cmd-next "increments the article pointer")
     ("HELP" ,#'cmd-help "displays this menu")
     ("LIST" ,#'cmd-list "lists all groups")
+    ("LIST NEWSGROUPS" ,#'cmd-list "same as LIST")
+    ("LIST ACTIVE" ,#'cmd-list "same as LIST")
+    ("LIST OVERVIEW.FMT" ,#'cmd-list "lists xover fields")
+    ("CAPABILITIES" ,#'cmd-capabilities "displays our capabilities")
     ("AUTHINFO" ,#'cmd-authinfo "makes me trust you")
     ("LOGIN" ,#'cmd-login "shorter interface to AUTHINFO")
     ("HEAD" ,#'cmd-head "fetches article headers")
@@ -485,6 +489,7 @@ commands, which is essentially what the user sees when asks for
     ("POST" ,#'cmd-post "posts your article")
     ("ARTICLE" ,#'cmd-article "fetches full articles")
     ("XOVER" ,#'cmd-xover "fetches the overview database of a group")
+    ("XHDR" ,#'cmd-xhdr "fetches a specific header from articles")
     ("CREATE-GROUP" ,#'cmd-create-group 
                     "creates a new group so you can discuss your favorite topic")
     ("CREATE-ACCOUNT",#'cmd-create-account 
@@ -1057,15 +1062,22 @@ foreign articles for whatever reason.
 
 (defun hs-lines (lines) (str:split (crlf-string) lines))
 
+(define-condition article-syntax-error (error)
+  ((message :initarg :message :reader article-syntax-error-message))
+  (:report (lambda (condition stream)
+             (format stream "~a" (article-syntax-error-message condition)))))
+
+(defun article-syntax-error! (fmt-str &rest args)
+  (error 'article-syntax-error
+         :message (apply #'fmt fmt-str args)))
+
 (defun parse-header (header)
   (let* ((h (str:collapse-whitespaces header))
          (pos (search ":" h)))
     (when (null pos)
-      (throw 'article-syntax-error
+      (article-syntax-error! (fmt "missing colon in header |~a|" h)))
-        (values nil (fmt "missing colon in header |~a|" h))))
     (when (<= (length h) (+ 2 pos))
-      (throw 'article-syntax-error
+      (article-syntax-error! (fmt "empty header ~a" h)))
-        (values nil (fmt "empty header ~a" h))))
     (multiple-value-bind (key val)
         (values (subseq h 0 pos) (subseq h (+ 2 pos)))
       (cons (str:downcase key) val))))
@@ -1482,12 +1494,39 @@ the future for a moment.
 (defstruct group name high low)
 
 (defun cmd-list (r)
+  (let* ((args (request-args r))
+         (keyw (and (= 1 (length args)) (car args))))
+    (cond
+      ((or (null args) (member keyw '("NEWSGROUPS" "ACTIVE") :test #'string-equal))
+       (list-groups-response r))
+       ((and keyw (string-equal keyw "OVERVIEW.FMT"))
+        (list-overview-fmt-response r))
+       (t (make-response :code 503 :request r
+                         :data (fmt "Unsupported LIST variant ``~a''." (str:join " " args)))))))
+
+(defun list-groups-response (r)
   (prepend-response-with 
    "Get in the loop! Lots to choose from."
    (make-response :code 215 :multi-line 'yes
                   :data (str:join (crlf-string) (build-groups-lines (build-groups-structs)))
                   :request r)))
 
+(defun list-overview-fmt-response (r)
+  (prepend-response-with
+   "What to expect in XOVER? These."
+   (make-response :code 215 :multi-line 'yes
+                  :data (str:join (crlf-string) (overview-fmt-lines))
+                  :request r)))
+
+(defun overview-fmt-lines ()
+  '("From:"
+    "Date:"
+    "Message-ID:"
+    "References:"
+    "Bytes:"
+    "Lines:"
+    "Xref:full"))
+
 (defun build-groups-lines (ls)
   (reverse
    (mapcar 
@@ -1604,6 +1643,20 @@ the future for a moment.
 (defun last-char (s) (char s (1- (length s))))
 @ 
 
+\begin{crossedblock}
+<<Dead Command list.lisp>>=
+(defstruct group name high low)
+
+(defun cmd-list (r)
+  (prepend-response-with 
+   "Get in the loop! Lots to choose from."
+   (make-response :code 215 :multi-line 'yes
+                  :data (str:join (crlf-string) (build-groups-lines (build-groups-structs)))
+                  :request r)))
+
+@ 
+\end{crossedblock}
+
 In [[basename]], what we want to do is---if the path ends with a
 slash, we invoke [[pathname]].  Otherwise, we invoke {\tt
   file-namestring}.
@@ -1672,6 +1725,37 @@ To list directories and files, I have been using
             collect (pathname-utils:force-directory path)))))
 @ %def loop-list-directories loop-list-files
 
+\subsection{{\tt LIST OVERVIEW.FMT}}
+
+This weirdly-named command is let news readers know what to expect in
+the answer to \verb|XOVER| commands.
+
+\begin{verbatim}
+215 What to expect in XOVER? These.
+Subject:
+From:
+Date:
+Message-ID:
+References:
+Bytes:
+Lines:
+Xref:full
+.
+\end{verbatim}
+
+Do we have support for commands with space?  I doubt it.  We don't.
+Our idea is that everything-LIST is to be handled by [[cmd-list]].
+This isn't such a bad idea, but it will make [[cmd-list]] handle
+
+<<Command list overview.fmt.lisp>>=
+(defun cmd-list-overview-fmt (r)
+  (prepend-response-with 
+   "Get in the loop! Lots to choose from."
+   (make-response :code 215 :multi-line 'yes
+                  :data (str:join (crlf-string) (build-groups-lines (build-groups-structs)))
+                  :request r)))
+@ 
+
 \subsection{{\tt GROUP}}\label{sec:group}
 
 We just need to verify if the group exists and modify [[*client*]].
@@ -1709,8 +1793,101 @@ specifies the article number.  In case (3), the NNTP client specifies
 the exact {\tt message-id}, which forces us to query the index---see
 Section~\ref{sec:index} for the implementation of the index.
 
+We're using the nonexistent procedure [[lookup-index]] below. We must
+update that now.  The argument [[n-or-mid]] is a message-id string for
+sure.  We can immediately return that article by reading /index/
+
 <<Commands head, body, article.lisp>>=
-(defun typical-cmd-head-body-article (r fn-name)
+(defun typical-cmd-head-body-article (r fn-by-number fn-by-mid)
+  (with-auth
+      (let ((args (request-args r)))
+        (cond ((null args)
+               (with-group-set
+                   (funcall fn-by-number r (client-group *client*) (client-article *client*))))
+              ((= 1 (length args))
+               (let* ((n-or-mid (car args)))
+                 (cond ((string-integer? n-or-mid)
+                        (with-group-set
+                            (funcall fn-by-number r (client-group *client*) n-or-mid)))
+                       (t (funcall fn-by-mid r n-or-mid)))))
+              (t (bad-input r "No, no: it takes at most two arguments."))))))
+
+(defun cmd-head (r)
+  (typical-cmd-head-body-article r #'head-response #'head-response-by-mid))
+(defun cmd-body (r)
+  (typical-cmd-head-body-article r #'body-response #'body-response-by-mid))
+(defun cmd-article (r)
+  (typical-cmd-head-body-article r #'article-response #'article-response-by-mid))
+
+(defun article-response (r g i)
+  (typical-cmd-response 220 r g i :article))
+(defun head-response (r g i)
+  (typical-cmd-response 221 r g i :head))
+(defun body-response (r g i)
+  (typical-cmd-response 222 r g i :body))
+
+(defun article-response-by-mid (r mid)
+  (typical-cmd-response-by-mid 220 r mid :article))
+(defun head-response-by-mid (r mid)
+  (typical-cmd-response-by-mid 221 r mid :head))
+(defun body-response-by-mid (r mid)
+  (typical-cmd-response-by-mid 222 r mid :body))
+
+(defun typical-cmd-response-at-path (code r path error-label response-number requested-part
+                                     &optional (not-found-code 400))
+  (handler-case
+      (let* ((headers-raw (read-headers-raw path)))
+        (if (null headers-raw)
+            (make-response :code 400 :request r :data (fmt "article ~a does not exist" error-label))
+            (let* ((a (parse-article headers-raw))
+                   (mid (extract-mid headers-raw))
+                   (head-length (length headers-raw))
+                   (body-start (+ head-length 4)) ;; 4 bytes due to \r\n\r\n
+                   (payload
+                     (ecase requested-part
+                       (:head (article-head a))
+                       (:body (make-file-stream-payload :path path :start-pos body-start))
+                       (:article (list (article-head a)
+                                       (crlf) (crlf)
+                                       (make-file-stream-payload :path path
+                                                                 :start-pos body-start))))))
+              (prepend-response-with (fmt "~a ~a" response-number mid)
+                                     (make-response :multi-line 'yes :code code
+                                                    :request r :data payload)))))
+    (file-error (c)
+      (declare (ignore c))
+      (make-response :code not-found-code :request r
+                     :data (fmt "Sorry, no such article ~a." error-label)))
+    (sb-posix:syscall-error (c)
+      (let ((msg (fmt "article ~a: ~a" error-label c)))
+        (stderr msg)
+        (make-response :code 400 :request r :data msg)))
+    (error (c)
+      (let ((msg (fmt "sorry ~a: ~a" error-label c)))
+        (stderr msg)
+        (make-response :code 400 :request r :data msg)))))
+
+(defun typical-cmd-response (code r g i requested-part)
+  (typical-cmd-response-at-path
+   code r
+   (fmt "groups/~a/~a" g i)
+   (fmt "~a/~a" g i) i requested-part 423))
+
+(defun typical-cmd-response-by-mid (code r mid requested-part)
+  (typical-cmd-response-at-path
+   code r
+   (index-path (index-hash mid))
+   mid
+   0 requested-part 400))
+@
+
+\begin{crossedblock}
+<<Dead.lisp>>=
+;; dead @ d17.M08.y2026.h16-0300.m36.s56
+;; --8<-------------------------------------------------------->8---
+;; old stuff below
+;; --8<-------------------------------------------------------->8---
+(defun typical-cmd-head-body-article-old (r fn-name)
   (with-auth
       (with-group-set
           (let ((args (request-args r)))
@@ -1726,20 +1903,21 @@ Section~\ref{sec:index} for the implementation of the index.
                                     (bad-input r (fmt "Unknown article ~a." n-or-mid))))))))
                   (t (bad-input r "No, no: it takes at most two arguments.")))))))
 
-(defun cmd-head (r)
+(defun cmd-head-old (r)
   (typical-cmd-head-body-article r #'head-response))
-(defun cmd-body (r)
+(defun cmd-body-old (r)
   (typical-cmd-head-body-article r #'body-response))
-(defun cmd-article (r)
+(defun cmd-article-old (r)
   (typical-cmd-head-body-article r #'article-response))
 
-(defun article-response (r g i)
+(defun article-response-old (r g i)
   (typical-cmd-response 220 r g i :article))
-(defun head-response (r g i)
+(defun head-response-old (r g i)
   (typical-cmd-response 221 r g i :head))
-(defun body-response (r g i)
+(defun body-response-old (r g i)
   (typical-cmd-response 222 r g i :body))
 @
+\end{crossedblock}
 
 \begin{crossedblock}
 In processing such commands, we need to verify the existence of files
@@ -1762,7 +1940,8 @@ want to do is to log it. What's important is that we seem to have
 enough code to treat any future case we might want to add and we're
 not ignoring any errors at all.
 
-<<Commands head, body, article.lisp>>=
+\begin{crossedblock}
+<<Dead Commands head, body, article.lisp>>=
 (defun typical-cmd-response (code r g i requested-part)
   (handler-case
       (let* ((path (fmt "groups/~a/~a" g i))
@@ -1794,6 +1973,7 @@ not ignoring any errors at all.
         (stderr msg)
         (make-response :code 400 :request r :data msg)))))
 @ %def typical-cmd-response
+\end{crossedblock}
 
 The command \verb|NEXT| has a slight different semantics.
 
@@ -1878,6 +2058,95 @@ to the last one.
   '("subject" "from" "date" "message-id" "references" "line-count" "byte-count"))
 @
 
+\subsection{{\tt XHDR}}
+
+The {\tt XHDR} command is defined by RFC 2980 section 2.6.  The
+purpose of this command is to let clients quickly grab specific
+information they're looking for.  Suppose a client is trying to build
+the thread of a certain message.  It wants to grab all articles whose
+message-id is listed by the \verb|references| header of the article.
+Then it says {\tt XHDR references <some.message.id>}.  It gets an
+answer such as
+%
+\begin{verbatim}
+xhdr references <some.message.id>
+221 Header information for references follows (from the article)
+<another.message.id> <yet.another.message.id> <a.third.one>
+.
+\end{verbatim}
+%
+The client can now issue a {\tt HEAD} for each of these ones.
+
+<<Command xhdr.lisp>>=
+(defun cmd-xhdr (r)
+  (with-auth
+      (with-group-set
+          (let ((args (request-args r)))
+            (cond
+              ((or (null args) (> (length args) 2))
+               (make-response :code 502 :request r
+                              :data "bad syntax: usage is XHDR header [range|message-id]"))
+              (t
+               (let ((header (string-downcase (car args)))
+                     (range-arg (cadr args)))
+                 (cond
+                   ((null range-arg)
+                    (xhdr r header (client-article *client*) (client-article *client*)))
+                   ((message-id-syntax? range-arg)
+                    (xhdr-by-message-id r header range-arg))
+                   (t
+                    (multiple-value-bind (fr to) (parse-range range-arg)
+                      (if (not fr)
+                          (make-response :code 502 :request r :data "bad syntax")
+                          (xhdr r header fr to))))))))))))
+
+(defun message-id-syntax? (s)
+  (and (> (length s) 0) (char= (char s 0) #\<)))
+
+(defun parse-range (s)
+  "Parses S of the form N, N-, or N-M. Returns (values from to), or
+   (values nil nil) when S doesn't conform."
+  (multiple-value-bind (matched v) (cl-ppcre:scan-to-strings "([0-9]+)([-]?)([0-9]*)" s)
+    (if (not matched)
+        (values nil nil)
+        (let ((fr (parse-integer (aref v 0)))
+              (hifen (aref v 1))
+              (to (ignore-errors (parse-integer (aref v 2)))))
+          (values fr (if (string= hifen "-") to fr))))))
+
+(defun xhdr (r header from to)
+  (assert (client-group *client*))
+  (let* ((g (client-group *client*))
+         (ls (get-articles g from to)))
+    (cond ((= 0 (length ls))
+           (make-response :code 420 :request r :data "no articles in the range"))
+          (t
+           (prepend-response-with
+            (fmt "~a header follows" header)
+            (make-response
+             :code 221 :request r :multi-line 'yes
+             :data (str:join
+                    (crlf-string)
+                    (loop for i in ls
+                          collect (xhdr-format-line i (get-header header (fetch-headers g i)))))))))))
+
+(defun xhdr-by-message-id (r header mid)
+  (multiple-value-bind (g n) (lookup-by-message-id mid)
+    (if (not (and g n))
+        (make-response :code 430 :request r :data "no such article")
+        (handler-case
+            (prepend-response-with
+             (fmt "~a header follows" header)
+             (make-response :code 221 :request r :multi-line 'yes
+                            :data (xhdr-format-line 0 (get-header header (fetch-headers g n)))))
+          (error (c)
+            (declare (ignore c))
+            (make-response :code 430 :request r :data "no such article"))))))
+
+(defun xhdr-format-line (i value)
+  (fmt "~a ~a" i value))
+@ %def cmd-xhdr
+
 \subsection{{\tt MODE READER}}\label{sec:mode-reader}
 
 So, we're always in reader mode, so we just ignore this command.
@@ -1978,44 +2247,38 @@ of trying to stop them.
 <<Command post.lisp>>=
 (defun cmd-post (r)
   (with-auth
-      (let ((suggested (suggest-message-id)))
+      (send-response!
-        (send-response!
+       (make-response :code 340
-         (make-response
+                      :data (fmt "Okay, go ahead. Suggested message-id ~a." (suggest-message-id))))
-          :code 340
+    (let ((tmp (fmt "tmp/post-~a.tmp" (random-string 12))))
-          :data (fmt "Okay, go ahead. Suggested message-id ~a." suggested)))
+      (unwind-protect
-        (let ((tmp (fmt "tmp/post-~a.tmp" (random-string 12))))
+           (handler-case
-          (unwind-protect
                (progn
                  (nntp-read-article-to-disk tmp)
-                 (stderr "finished writing article to disk in tmp/~a~%" tmp)
+                 (stderr "finished writing article to disk in ~a~%" tmp)
                  (let* ((headers-raw (read-headers-raw tmp))
-                        ;; headers-raw includes the terminating CRLF CRLF; strip it
-                        ;; so parse-headers does not see an empty final line.
                         (headers-str (bytes->string headers-raw))
                         (hds (parse-headers headers-str))
                         (mid (get-header "message-id" hds))
                         (ngs (newsgroups-header->list (get-header "newsgroups" hds))))
                    (stderr "finished reading the headers of the tmp file~%")
                    (stderr "headers string: ~a~%" headers-str)
-                   (multiple-value-bind (okay? error) (conforms-headers? headers-str)
+                   (conforms-headers? headers-str) ;; raises a condition if it doesn't go well
-                     (cond
+                   (let* ((hash (store-article-in-index! tmp mid)))
-                       ((not okay?)
+                     (stderr "stored ~a from ~a~%" hash mid)
-                        (make-response
+                     (dolist (ng ngs)
+                       (let ((new-id (link-article-into-group-insist! hash ng (get-next-article-id ng))))
+                         (update-group-meta-incremental! ng new-id)))
+                     (stderr "linking finished~%")
+                     (update-last-post-date! (client-username *client*))
+                     (make-response :code 240 :request r :data "Thank you! Your article has been saved."))))
+             (article-syntax-error (c)
+               (make-response
                          :code 400 :request r
-                         :data (fmt "Sorry. Your article doesn't conform: ~a." error)))
+                         :data (fmt "Sorry. Your article doesn't conform: ~a." c)))
-                       (t
+             (already-seen-article (c)
-                        (handler-case
+               (make-response :code 441 :request r :data (fmt "~a" c))))
-                            (let* ((hash (store-article-in-index! tmp mid)))
+        (ignore-errors (delete-file tmp))))))
-                              (stderr "stored ~a from ~a~%" hash mid)
-                              (dolist (ng ngs)
-                                (let ((new-id (link-article-into-group-insist! hash ng (get-next-article-id ng))))
-                                  (update-group-meta-incremental! ng new-id)))
-                              (stderr "Procedure post has finished.~%")
-                              (update-last-post-date! (client-username *client*))
-                              (make-response :code 240 :request r :data "Thank you! Your article has been saved."))
-                          (already-seen-article (c)
-                            (make-response :code 441 :request r :data (fmt "~a" c)))))))))
-            (ignore-errors (delete-file tmp)))))))
 @
 
 <<Command post.lisp>>=
@@ -2046,7 +2309,7 @@ file next to it and atomically rename it into place.
 @
 
 \begin{crossedblock}
-<<Command post.lisp>>=
+<<Dead Command post.lisp>>=
 (defun save-article-try-old (g name-try tmp-path)
   (stderr "going to try to save ~a with name ~a/~a~%" tmp-path g name-try)
   (let ((name (fmt "~a" name-try))
@@ -2343,39 +2606,43 @@ 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 the article is susceptible to be saved.
 
+\begin{crossedblock}
 So the message here is that if an article is vetted by [[conforms?]],
 then it can be saved.  Any problem with the article must be reported
 by [[conforms?]].
 
-<<Does an article conform?.lisp>>=
+<<Dead Does and article conform?.lisp>>=
-(defun conforms? (bs)
+(defun conforms?-old (bs)
-  (catch 'article-syntax-error
+  (conforms-headers? (article-head (parse-article bs))))
-    (conforms-headers?
+@
-     (article-head (parse-article bs)))))
+\end{crossedblock}
 
+<<Does an article conform?.lisp>>=
 (defun conforms-headers? (headers-str)
   "HEADERS-STR is the raw header block (without the body).
    Returns (values T NIL) on success, or (values NIL error-string)."
-  (catch 'article-syntax-error
+  (let* ((headers (parse-headers headers-str))
-    (let ((headers (parse-headers headers-str)))
+         (missing (loop for h in (headers-required-from-clients)
-      (let ((result (dolist (h (headers-required-from-clients))
+                        unless (lookup h headers)
-                      (when (not (lookup h headers))
+                        collect h)))
-                        (return (fmt "missing the /~a/ header" h))))))
+    (cond
-        (cond
+      (missing (article-syntax-error!
-          ((stringp result) (values nil result))
+                (fmt "missing the ~a ~a"
-          (t
+                     (str:join ", " (mapcar (lambda (h) (fmt "/~a/" h)) missing))
-           (let ((ngs (newsgroups-header->list (get-header "newsgroups" headers)))
+                     (word-plural (length missing) "header"))))
-                 (ngs-dont-exist nil))
+      (t
-             (dolist (g ngs)
+       (let ((ngs (newsgroups-header->list (get-header "newsgroups" headers)))
-               (when (or (not (group-name-conforms? g))
+             (ngs-dont-exist nil))
-                         (not (group? g)))
+         (dolist (g ngs)
-                 (push g ngs-dont-exist)))
+           (when (or (not (group-name-conforms? g))
-             (if (not (zerop (length ngs-dont-exist)))
+                     (not (group? g)))
-                 (values nil (fmt "the ~a ~a just ~a exist"
+             (push g ngs-dont-exist)))
-                                     (word-plural (length ngs-dont-exist) "newsgroup")
+         (if (not (zerop (length ngs-dont-exist)))
-                                     (str:join ", " (sort ngs-dont-exist #'string<))
+             (article-syntax-error! (fmt "the ~a ~a just ~a exist"
-                                     (word-plural (length ngs-dont-exist) "doesn't")))
+                                         (word-plural (length ngs-dont-exist) "newsgroup")
-                 (values t nil)))))))))
+                                         (str:join ", " (sort ngs-dont-exist #'string<))
+                                         (word-plural (length ngs-dont-exist) "doesn't")))
+             (values t nil)))))))
 
 (defun text/plain? (header-s)
   ;; I say T when S begins with "text/plain" or when S is "".
@@ -2464,6 +2731,26 @@ they're skilled enough.
 (defparameter *enable-nntp-repl* t)
 @ 
 
+\subsection{CAPABILITIES}
+
+<<Command capabilities.lisp>>=
+(defun cmd-capabilities (r)
+  (prepend-response-with
+   "We are very capable! Please, take note:"
+   (make-response
+    :code 101 :multi-line 'yes :request r
+    :data (str:join (crlf-string) (capabilities-lines)))))
+
+(defun capabilities-lines ()
+  (append
+   (list "VERSION 2"
+         "READER")
+   (when (auth?) (list "POST"))
+   (list "AUTHINFO USER"
+         "LIST ACTIVE NEWSGROUPS OVERVIEW.FMT"
+         (fmt "IMPLEMENTATION LOOP ~a" *git-hash*))))
+@
+
 \section{Publication of news}
 
 If you're interested in being notified about what's going on in the
@@ -3143,10 +3430,12 @@ something to think about.
 <<How to stream off articles.lisp>>
 <<How to index articles.lisp>>
 <<Dispatching of commands.lisp>>
+<<Command capabilities.lisp>>
 <<Command authinfo.lisp>>
 <<Command mode reader.lisp>>
 <<Commands head, body, article.lisp>>
 <<Command xover.lisp>>
+<<Command xhdr.lisp>>
 <<Command group.lisp>>
 <<Command list.lisp>>
 <<Command help.lisp>>

version.lisp

@@ -1,2 +1,2 @@
 (in-package :loop)
-(defparameter *git-hash* "d44771c")
+(defparameter *git-hash* "05be4aa")