diff --git a/loop.lisp b/loop.lisp
index ccb3043..188d40d 100644
--- a/loop.lisp
+++ b/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 (< n 2) (car w) (cdr w)))))
+ (if (not 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)
- (append hs
- `(("line-count" . ,(fmt "~a" (nlines (article-body a-parsed))))
- ("byte-count" . ,(fmt "~a" (length a-raw))))))
+(defun enrich-headers (hs art-path)
+ "Dynamically computes bytes and lines to the parsed header alist."
+ (append hs
+ `(("bytes" . ,(fmt "~a" (filesize art-path)))
+ ("lines" . ,(fmt "~a" (count-lines-at-path art-path))))))
-(defun nlines (v)
- (loop for b across v
- count (= b 10)))
+(defun count-lines-at-path (path)
+ "Constant-memory---8 KiB---line counter."
+ (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
diff --git a/loop.nw b/loop.nw
index e761cfb..e2a010c 100644
--- a/loop.nw
+++ b/loop.nw
@@ -474,6 +474,7 @@ commands, which is essentially what the user sees when asks for
<
>=
(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.
-The headers themselves can be turned into a string. For the body,
-we're going to use a great feature of Common Lisp---a zero-copy array
-window into the original array [[v]], the argument of the procedure.
-The feature is requested by the [[:displaced-to]] keyword, which
-specifies the original array, where our window begins is specified by
-the long offset keyword. The length of our window has to be the
-entire article body, which is the length of the vector minus the head
-and the separator \verb|\r\n\r\n|, which is 4 bytes long.
+which separates head and body. The headers themselves can be turned
+into a string. For the body, we're going to use a great feature of
+Common Lisp---a zero-copy array window into the original array [[v]],
+the argument of the procedure. The feature is requested by the
+[[:displaced-to]] keyword, which specifies the original array, where
+our window begins is specified by the long offset keyword. The length
+of our window has to be the entire article body, which is the length
+of the vector minus the head and the separator \verb|\r\n\r\n|, which
+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)
- (append hs
- `(("line-count" . ,(fmt "~a" (nlines (article-body a-parsed))))
- ("byte-count" . ,(fmt "~a" (length a-raw))))))
+(defun enrich-headers (hs art-path)
+ "Dynamically computes bytes and lines to the parsed header alist."
+ (append hs
+ `(("bytes" . ,(fmt "~a" (filesize art-path)))
+ ("lines" . ,(fmt "~a" (count-lines-at-path art-path))))))
-(defun nlines (v)
- (loop for b across v
- count (= b 10)))
+(defun count-lines-at-path (path)
+ "Constant-memory---8 KiB---line counter."
+ (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.
+
+<>=
+(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 (< n 2) (car w) (cdr w)))))
+ (if (not 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.
<>
<>
<>
+<>
<>
<>
<>
diff --git a/scripts/build-index-from-fs.lisp b/scripts/build-index-from-fs.lisp
index ed02e93..26f6a6e 100644
--- a/scripts/build-index-from-fs.lisp
+++ b/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)
diff --git a/scripts/verify-index.lisp b/scripts/verify-index.lisp
index 4525bba..70f9379 100644
--- a/scripts/verify-index.lisp
+++ b/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~%"
- g i-str grp-inode idx-inode idx-path))
+ (stdout "okay ~a/~a shares-inode ~a with ~a~%"
+ 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))))))))))
diff --git a/version.lisp b/version.lisp
index 97345a7..b0a900f 100644
--- a/version.lisp
+++ b/version.lisp
@@ -1,2 +1,2 @@
(in-package :loop)
-(defparameter *git-hash* "d532d44")
+(defparameter *git-hash* "33b3a7d")