Implements LISTGROUP and provides bytes correctly in XOVER.

loop.lisp

@@ -42,6 +42,7 @@
 
 (defun table-of-commands ()
   `(("GROUP" ,#'cmd-group "sets the current group") 
+    ("LISTGROUP" ,#'cmd-listgroup "lists the exact articles a group has")
     ("NEXT" ,#'cmd-next "increments the article pointer")
     ("HELP" ,#'cmd-help "displays this menu")
     ("LIST" ,#'cmd-list "lists all groups")
@@ -186,8 +187,9 @@
   (let ((table '(("doesn't" . "don't")
                  ("newsgroup" . "newsgroups"))))
     (let ((w (assoc word table :test #'string=)))
-      (when (not w) (error "word not found"))
+      (if (not w) 
-      (if (< n 2) (car w) (cdr w)))))
+          (str:concat word "s") ;; assume s as suffix
+          (if (< n 2) (car w) (cdr w))))))
 
 (defun plural (v suffix)
   (if (> v 1) suffix ""))
@@ -440,19 +442,39 @@
     (if pair (cdr pair) "")))
 
 (defun fetch-headers (g i)
+  "Loads the article, parses headers, and computes missing metadata dynamically."
+  (let* ((art-path (fmt "groups/~a/~a" g i))
+         (a-string (fetch-article g i))
+         (a-parsed (parse-article a-string))
+         (headers (parse-headers (article-head a-parsed))))
+    (enrich-headers headers art-path)))
+
+(defun fetch-headers-destroy (g i)
   (let* ((a-string (fetch-article g i))
          (a-parsed (parse-article a-string))
          (headers (parse-headers (article-head a-parsed))))
-    (enrich-headers headers a-string a-parsed)))
+    headers))
 
-(defun enrich-headers (hs a-raw a-parsed)
+(defun enrich-headers (hs art-path)
-  (append hs
+  "Dynamically computes bytes and lines to the parsed header alist."
-    `(("line-count" . ,(fmt "~a" (nlines (article-body a-parsed))))
+  (append hs 
-      ("byte-count" . ,(fmt "~a" (length a-raw))))))
+    `(("bytes" . ,(fmt "~a" (filesize art-path)))
+      ("lines" . ,(fmt "~a" (count-lines-at-path art-path))))))
 
-(defun nlines (v)
+(defun count-lines-at-path (path)
-  (loop for b across v
+  "Constant-memory---8 KiB---line counter."
-        count (= b 10)))
+  (with-open-file (in path :direction :input :element-type '(unsigned-byte 8))
+    (let ((buf (make-array 8192 :element-type '(unsigned-byte 8)))
+          (lines 0))
+      (declare (type (simple-array (unsigned-byte 8) (8192)) buf)
+               (type fixnum lines)
+               (optimize (speed 3) (safety 1)))
+      (loop for n fixnum = (read-sequence buf in)
+            while (plusp n)
+            do (loop for i fixnum from 0 below n
+                     when (= (aref buf i) 10)
+                     do (incf lines)))
+      lines)))
 
 (defun extract-mid (a)
   (lookup "message-id" (parse-headers (article-head (parse-article a)))))
@@ -767,6 +789,11 @@
                                                 :test #'string=))
                                     (fetch-headers g i)))))))))))
 
+(defun xover-format-line-new (i hs)
+  (str:concat (fmt "~a~a" i #\tab)
+              (str:join #\tab (mapcar #'(lambda (h) (or (get-header h hs) ""))
+                                      (xover-headers)))))
+
 (defun xover-format-line (i hs)
   (str:concat (fmt "~a~a" i #\tab)
               (str:join #\tab 
@@ -774,7 +801,7 @@
                                 (xover-headers)))))
 
 (defun xover-headers ()
-  '("subject" "from" "date" "message-id" "references" "line-count" "byte-count"))
+  '("subject" "from" "date" "message-id" "references" "bytes" "lines"))
 
 (defun cmd-xhdr (r)
   (with-auth
@@ -1058,6 +1085,80 @@
         (car (last (pathname-directory s)))
         (file-namestring s))))
 
+(defun parse-nntp-range (range-str default-low default-high)
+  "Parses an NNTP range string into (values low high)."
+  (if (null range-str)
+      (values default-low default-high)
+      (let ((dash-pos (position #\- range-str)))
+        (if (not dash-pos) ;; Didn't find a dash.
+            (let ((n (parse-integer range-str :junk-allowed t)))
+              (values (or n default-low) (or n default-high)))
+            (let ((start-val (parse-integer (subseq range-str 0 dash-pos) :junk-allowed t))
+                  (end-str (subseq range-str (1+ dash-pos))))
+              (if (string= end-str "")
+                  ;; Found an article number followed by a dash as in
+                  ;; 123-.
+                  (values (or start-val default-low) default-high)
+                  ;; Found an article number followed by a dash and
+                  ;; another number as in 123-456.
+                  (let ((end-val (parse-integer end-str :junk-allowed t)))
+                    (values (or start-val default-low) (or end-val default-high)))))))))
+
+(defun cmd-listgroup (r)
+  (with-auth
+    (let* ((args (request-args r))
+           (g (if args (car args) (client-group *client*)))
+           (range-arg (if (> (length args) 1) (cadr args) nil)))
+      (cond
+        ((> (length args) 2)
+         (make-response :code 400 :request r :data "No, no: LISTGROUP takes at most two arguments."))
+        ((not g)
+         (make-response :code 412 :request r :data "No newsgroup selected"))
+        (t
+         (with-group g r
+           (set-group! g)
+           (multiple-value-bind (group-low group-high group-len) (group-high-low g)
+             (multiple-value-bind (req-low req-high)
+                 (parse-nntp-range range-arg group-low group-high)
+               (let* ((all-articles (get-articles g group-low group-high))
+                      (filtered-articles (remove-if-not (lambda (x) (and (>= x req-low) (<= x req-high)))
+                                                        all-articles)))
+                 (when all-articles
+                   (setf (client-article *client*) (car all-articles)))
+                 (prepend-response-with (fmt "~a ~a ~a ~a list follows" group-len group-low group-high g)
+                   (make-response :code 211
+                                  :request r
+                                  :multi-line 'yes
+                                  :data (if filtered-articles
+                                            (str:join (crlf-string) (mapcar #'write-to-string filtered-articles))
+                                            ""))))))))))))
+
+(defun cmd-listgroup-old (r)
+  (with-auth
+    (let* ((args (request-args r))
+           (g (if args (car args) (client-group *client*))))
+      (cond
+        ;; If no group is selected and no argument was provided...
+        ((not g)
+         (make-response :code 412 :request r :data "must say GROUP first"))
+        ;; When LISTGROUP takes at most one argument (the group name)...
+        ((> (length args) 1)
+         (make-response :code 400 :request r :data "No, no: LISTGROUP takes at most one argument."))
+        (t
+         (with-group g r
+           (set-group! g)
+           (multiple-value-bind (low high len) (group-high-low g)
+             ;; Fetch the list of article integers
+             (let ((articles (get-articles g low high)))
+               (setf (client-article *client*) low)
+               ;; Prepend the 211 success line and format the multi-line response
+               (prepend-response-with (fmt "~a ~a ~a ~a article numbers follow" len low high g)
+                 (make-response :code 211
+                                :request r
+                                :multi-line 'yes
+                                :data (str:join (crlf-string)
+                                                (mapcar #'write-to-string articles))))))))))))
+
 (defun cmd-help (r)
   (labels ((menu (ls)
              (loop for item in ls 

loop.nw

@@ -474,6 +474,7 @@ commands, which is essentially what the user sees when asks for
 <<Table of commands.lisp>>=
 (defun table-of-commands ()
   `(("GROUP" ,#'cmd-group "sets the current group") 
+    ("LISTGROUP" ,#'cmd-listgroup "lists the exact articles a group has")
     ("NEXT" ,#'cmd-next "increments the article pointer")
     ("HELP" ,#'cmd-help "displays this menu")
     ("LIST" ,#'cmd-list "lists all groups")
@@ -1027,15 +1028,15 @@ Implement these limits---pretty easy task.
 
 The input is a vector of bytes, bytes that represent the article
 written on the file system.  First, search for the \verb|\r\n\r\n|,
-which is bytes \verb|#(13 10 13 10)|, that separates head and body.
+which separates head and body.  The headers themselves can be turned
-The headers themselves can be turned into a string.  For the body,
+into a string.  For the body, we're going to use a great feature of
-we're going to use a great feature of Common Lisp---a zero-copy array
+Common Lisp---a zero-copy array window into the original array [[v]],
-window into the original array [[v]], the argument of the procedure.
+the argument of the procedure.  The feature is requested by the
-The feature is requested by the [[:displaced-to]] keyword, which
+[[:displaced-to]] keyword, which specifies the original array, where
-specifies the original array, where our window begins is specified by
+our window begins is specified by the long offset keyword.  The length
-the long offset keyword.  The length of our window has to be the
+of our window has to be the entire article body, which is the length
-entire article body, which is the length of the vector minus the head
+of the vector minus the head and the separator \verb|\r\n\r\n|, which
-and the separator \verb|\r\n\r\n|, which is 4 bytes long.
+is 4 bytes long.
 
 An article that would have no separator and no body would not be an
 article.  But still, I'd rather be very careful here and create an
@@ -1099,19 +1100,39 @@ they're still part of parsing an article.
     (if pair (cdr pair) "")))
 
 (defun fetch-headers (g i)
+  "Loads the article, parses headers, and computes missing metadata dynamically."
+  (let* ((art-path (fmt "groups/~a/~a" g i))
+         (a-string (fetch-article g i))
+         (a-parsed (parse-article a-string))
+         (headers (parse-headers (article-head a-parsed))))
+    (enrich-headers headers art-path)))
+
+(defun fetch-headers-destroy (g i)
   (let* ((a-string (fetch-article g i))
          (a-parsed (parse-article a-string))
          (headers (parse-headers (article-head a-parsed))))
-    (enrich-headers headers a-string a-parsed)))
+    headers))
 
-(defun enrich-headers (hs a-raw a-parsed)
+(defun enrich-headers (hs art-path)
-  (append hs
+  "Dynamically computes bytes and lines to the parsed header alist."
-    `(("line-count" . ,(fmt "~a" (nlines (article-body a-parsed))))
+  (append hs 
-      ("byte-count" . ,(fmt "~a" (length a-raw))))))
+    `(("bytes" . ,(fmt "~a" (filesize art-path)))
+      ("lines" . ,(fmt "~a" (count-lines-at-path art-path))))))
 
-(defun nlines (v)
+(defun count-lines-at-path (path)
-  (loop for b across v
+  "Constant-memory---8 KiB---line counter."
-        count (= b 10)))
+  (with-open-file (in path :direction :input :element-type '(unsigned-byte 8))
+    (let ((buf (make-array 8192 :element-type '(unsigned-byte 8)))
+          (lines 0))
+      (declare (type (simple-array (unsigned-byte 8) (8192)) buf)
+               (type fixnum lines)
+               (optimize (speed 3) (safety 1)))
+      (loop for n fixnum = (read-sequence buf in)
+            while (plusp n)
+            do (loop for i fixnum from 0 below n
+                     when (= (aref buf i) 10)
+                     do (incf lines)))
+      lines)))
 @ %def get-header fetch-headers
 
 The procedures [[extract-mid]] and [[lookup]] also belong belong in
@@ -1756,6 +1777,87 @@ This isn't such a bad idea, but it will make [[cmd-list]] handle
                   :request r)))
 @ 
 
+\subsection{{\tt LISTGROUP}}\label{sec:listgroup}
+
+A useful command.  Clients such as {\em Sylpheed} ignore it, but {\em
+  tin} takes advantage of it.
+
+<<Command listgroup.lisp>>=
+(defun parse-nntp-range (range-str default-low default-high)
+  "Parses an NNTP range string into (values low high)."
+  (if (null range-str)
+      (values default-low default-high)
+      (let ((dash-pos (position #\- range-str)))
+        (if (not dash-pos) ;; Didn't find a dash.
+            (let ((n (parse-integer range-str :junk-allowed t)))
+              (values (or n default-low) (or n default-high)))
+            (let ((start-val (parse-integer (subseq range-str 0 dash-pos) :junk-allowed t))
+                  (end-str (subseq range-str (1+ dash-pos))))
+              (if (string= end-str "")
+                  ;; Found an article number followed by a dash as in
+                  ;; 123-.
+                  (values (or start-val default-low) default-high)
+                  ;; Found an article number followed by a dash and
+                  ;; another number as in 123-456.
+                  (let ((end-val (parse-integer end-str :junk-allowed t)))
+                    (values (or start-val default-low) (or end-val default-high)))))))))
+
+(defun cmd-listgroup (r)
+  (with-auth
+    (let* ((args (request-args r))
+           (g (if args (car args) (client-group *client*)))
+           (range-arg (if (> (length args) 1) (cadr args) nil)))
+      (cond
+        ((> (length args) 2)
+         (make-response :code 400 :request r :data "No, no: LISTGROUP takes at most two arguments."))
+        ((not g)
+         (make-response :code 412 :request r :data "No newsgroup selected"))
+        (t
+         (with-group g r
+           (set-group! g)
+           (multiple-value-bind (group-low group-high group-len) (group-high-low g)
+             (multiple-value-bind (req-low req-high)
+                 (parse-nntp-range range-arg group-low group-high)
+               (let* ((all-articles (get-articles g group-low group-high))
+                      (filtered-articles (remove-if-not (lambda (x) (and (>= x req-low) (<= x req-high)))
+                                                        all-articles)))
+                 (when all-articles
+                   (setf (client-article *client*) (car all-articles)))
+                 (prepend-response-with (fmt "~a ~a ~a ~a article list follows" group-len group-low group-high g)
+                   (make-response :code 211
+                                  :request r
+                                  :multi-line 'yes
+                                  :data (if filtered-articles
+                                            (str:join (crlf-string) (mapcar #'write-to-string filtered-articles))
+                                            ""))))))))))))
+
+(defun cmd-listgroup-old (r)
+  (with-auth
+    (let* ((args (request-args r))
+           (g (if args (car args) (client-group *client*))))
+      (cond
+        ;; If no group is selected and no argument was provided...
+        ((not g)
+         (make-response :code 412 :request r :data "must say GROUP first"))
+        ;; When LISTGROUP takes at most one argument (the group name)...
+        ((> (length args) 1)
+         (make-response :code 400 :request r :data "No, no: LISTGROUP takes at most one argument."))
+        (t
+         (with-group g r
+           (set-group! g)
+           (multiple-value-bind (low high len) (group-high-low g)
+             ;; Fetch the list of article integers
+             (let ((articles (get-articles g low high)))
+               (setf (client-article *client*) low)
+               ;; Prepend the 211 success line and format the multi-line response
+               (prepend-response-with (fmt "~a ~a ~a ~a article numbers follow" len low high g)
+                 (make-response :code 211
+                                :request r
+                                :multi-line 'yes
+                                :data (str:join (crlf-string)
+                                                (mapcar #'write-to-string articles))))))))))))
+@ 
+
 \subsection{{\tt GROUP}}\label{sec:group}
 
 We just need to verify if the group exists and modify [[*client*]].
@@ -2049,13 +2151,19 @@ to the last one.
                                         (member (car h) (xover-headers) 
                                                 :test #'string=))
                                     (fetch-headers g i)))))))))))
+
+(defun xover-format-line-new (i hs)
+  (str:concat (fmt "~a~a" i #\tab)
+              (str:join #\tab (mapcar #'(lambda (h) (or (get-header h hs) ""))
+                                      (xover-headers)))))
+
 (defun xover-format-line (i hs)
   (str:concat (fmt "~a~a" i #\tab)
               (str:join #\tab 
                         (mapcar #'(lambda (h) (get-header h hs))
                                 (xover-headers)))))
 (defun xover-headers ()
-  '("subject" "from" "date" "message-id" "references" "line-count" "byte-count"))
+  '("subject" "from" "date" "message-id" "references" "bytes" "lines"))
 @
 
 \subsection{{\tt XHDR}}
@@ -3370,8 +3478,9 @@ Of small importance, they have nothing.
   (let ((table '(("doesn't" . "don't")
                  ("newsgroup" . "newsgroups"))))
     (let ((w (assoc word table :test #'string=)))
-      (when (not w) (error "word not found"))
+      (if (not w) 
-      (if (< n 2) (car w) (cdr w)))))
+          (str:concat word "s") ;; assume s as suffix
+          (if (< n 2) (car w) (cdr w))))))
 
 (defun plural (v suffix)
   (if (> v 1) suffix ""))
@@ -3584,6 +3693,7 @@ something to think about.
 <<Command xhdr.lisp>>
 <<Command group.lisp>>
 <<Command list.lisp>>
+<<Command listgroup.lisp>>
 <<Command help.lisp>>
 <<Command quit.lisp>>
 <<Command date.lisp>>

scripts/build-index-from-fs.lisp

@@ -29,7 +29,7 @@
                     (handler-case
                         (progn
                           (sb-posix:link (uiop:native-namestring path) idx-path)
-                          (format t "article ~a/~a indexed by ~a (~a)~%" g i m hash))
+                          (format t "article ~a/~a indexed by ~a hash ~a~%" g i m hash))
                       (sb-posix:syscall-error (c)
                         (if (= (sb-posix:syscall-errno c) sb-posix:eexist)
                             (format t "article ~a/~a already indexed concurrently.~%" g i)

scripts/verify-index.lisp

@@ -26,8 +26,8 @@
                           (stdout "no-index ~a/~a mid ~a hashes-to ~a~%"
                                   g i-str mid idx-path))
                          ((= grp-inode idx-inode)
-                          (stdout "okay ~a/~a shares-inode ~a = ~a hashed-at ~a~%"
+                          (stdout "okay ~a/~a shares-inode ~a with ~a~%"
-                                  g i-str grp-inode idx-inode idx-path))
+                                  g i-str grp-inode idx-path))
                          (t
                           (stdout "mismatch ~a/~a inode ~a =/= inode ~a hash ~a~%"
                                   g i-str grp-inode idx-inode idx-path))))))))))

version.lisp

@@ -1,2 +1,2 @@
 (in-package :loop)
-(defparameter *git-hash* "d532d44")
+(defparameter *git-hash* "33b3a7d")