Implements LISTGROUP and provides bytes correctly in XOVER.
This commit is contained in:
parent
33b3a7da01
commit
1536193116
5 changed files with 246 additions and 35 deletions
123
loop.lisp
123
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
|
||||
|
|
|
|||
150
loop.nw
150
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.
|
||||
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.
|
||||
|
||||
<<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 (< 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.
|
|||
<<Command xhdr.lisp>>
|
||||
<<Command group.lisp>>
|
||||
<<Command list.lisp>>
|
||||
<<Command listgroup.lisp>>
|
||||
<<Command help.lisp>>
|
||||
<<Command quit.lisp>>
|
||||
<<Command date.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)
|
||||
|
|
|
|||
|
|
@ -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))))))))))
|
||||
|
|
|
|||
|
|
@ -1,2 +1,2 @@
|
|||
(in-package :loop)
|
||||
(defparameter *git-hash* "d532d44")
|
||||
(defparameter *git-hash* "33b3a7d")
|
||||
|
|
|
|||
Loading…
Reference in a new issue