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")