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.
This commit is contained in:
parent
05be4aad57
commit
e1826ad9eb
3 changed files with 575 additions and 183 deletions
335
loop.lisp
335
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
|
||||
(values nil (fmt "missing colon in header |~a|" h))))
|
||||
(article-syntax-error! (fmt "missing colon in header |~a|" h)))
|
||||
(when (<= (length h) (+ 2 pos))
|
||||
(throw 'article-syntax-error
|
||||
(values nil (fmt "empty header ~a" h))))
|
||||
(article-syntax-error! (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)))
|
||||
(cond ((null args)
|
||||
(funcall fn-name r (client-group *client*) (client-article *client*)))
|
||||
((= 1 (length args))
|
||||
(let* ((n-or-mid (car args)))
|
||||
(cond ((string-integer? n-or-mid)
|
||||
(funcall fn-name r (client-group *client*) n-or-mid))
|
||||
(t (multiple-value-bind (group n-str) (lookup-index n-or-mid)
|
||||
(if (and group n-str)
|
||||
(funcall fn-name r group n-str)
|
||||
(bad-input r (fmt "Unknown article ~a." n-or-mid))))))))
|
||||
(t (bad-input r "No, no: it takes at most two arguments.")))))))
|
||||
(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))
|
||||
(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))
|
||||
(headers-raw (read-headers-raw path)))
|
||||
(let* ((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 ((result (dolist (h (headers-required-from-clients))
|
||||
(when (not (lookup h headers))
|
||||
(return (fmt "missing the /~a/ header" h))))))
|
||||
(cond
|
||||
((stringp result) (values nil result))
|
||||
(t
|
||||
(let ((ngs (newsgroups-header->list (get-header "newsgroups" headers)))
|
||||
(ngs-dont-exist nil))
|
||||
(dolist (g ngs)
|
||||
(when (or (not (group-name-conforms? g))
|
||||
(not (group? g)))
|
||||
(push g ngs-dont-exist)))
|
||||
(if (not (zerop (length ngs-dont-exist)))
|
||||
(values nil (fmt "the ~a ~a just ~a exist"
|
||||
(word-plural (length ngs-dont-exist) "newsgroup")
|
||||
(str:join ", " (sort ngs-dont-exist #'string<))
|
||||
(word-plural (length ngs-dont-exist) "doesn't")))
|
||||
(values t nil)))))))))
|
||||
(let* ((headers (parse-headers headers-str))
|
||||
(missing (loop for h in (headers-required-from-clients)
|
||||
unless (lookup h headers)
|
||||
collect h)))
|
||||
(cond
|
||||
(missing (article-syntax-error!
|
||||
(fmt "missing the ~a ~a"
|
||||
(str:join ", " (mapcar (lambda (h) (fmt "/~a/" h)) missing))
|
||||
(word-plural (length missing) "header"))))
|
||||
(t
|
||||
(let ((ngs (newsgroups-header->list (get-header "newsgroups" headers)))
|
||||
(ngs-dont-exist nil))
|
||||
(dolist (g ngs)
|
||||
(when (or (not (group-name-conforms? g))
|
||||
(not (group? g)))
|
||||
(push g ngs-dont-exist)))
|
||||
(if (not (zerop (length ngs-dont-exist)))
|
||||
(article-syntax-error! (fmt "the ~a ~a just ~a exist"
|
||||
(word-plural (length ngs-dont-exist) "newsgroup")
|
||||
(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!
|
||||
(make-response
|
||||
:code 340
|
||||
:data (fmt "Okay, go ahead. Suggested message-id ~a." suggested)))
|
||||
(let ((tmp (fmt "tmp/post-~a.tmp" (random-string 12))))
|
||||
(unwind-protect
|
||||
(send-response!
|
||||
(make-response :code 340
|
||||
:data (fmt "Okay, go ahead. Suggested message-id ~a." (suggest-message-id))))
|
||||
(let ((tmp (fmt "tmp/post-~a.tmp" (random-string 12))))
|
||||
(unwind-protect
|
||||
(handler-case
|
||||
(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)
|
||||
(cond
|
||||
((not okay?)
|
||||
(make-response
|
||||
(conforms-headers? headers-str) ;; raises a condition if it doesn't go well
|
||||
(let* ((hash (store-article-in-index! tmp mid)))
|
||||
(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 "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)))
|
||||
(t
|
||||
(handler-case
|
||||
(let* ((hash (store-article-in-index! tmp mid)))
|
||||
(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)))))))
|
||||
:data (fmt "Sorry. Your article doesn't conform: ~a." c)))
|
||||
(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)))
|
||||
|
|
|
|||
421
loop.nw
421
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
|
||||
(values nil (fmt "missing colon in header |~a|" h))))
|
||||
(article-syntax-error! (fmt "missing colon in header |~a|" h)))
|
||||
(when (<= (length h) (+ 2 pos))
|
||||
(throw 'article-syntax-error
|
||||
(values nil (fmt "empty header ~a" h))))
|
||||
(article-syntax-error! (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!
|
||||
(make-response
|
||||
:code 340
|
||||
:data (fmt "Okay, go ahead. Suggested message-id ~a." suggested)))
|
||||
(let ((tmp (fmt "tmp/post-~a.tmp" (random-string 12))))
|
||||
(unwind-protect
|
||||
(send-response!
|
||||
(make-response :code 340
|
||||
:data (fmt "Okay, go ahead. Suggested message-id ~a." (suggest-message-id))))
|
||||
(let ((tmp (fmt "tmp/post-~a.tmp" (random-string 12))))
|
||||
(unwind-protect
|
||||
(handler-case
|
||||
(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)
|
||||
(cond
|
||||
((not okay?)
|
||||
(make-response
|
||||
(conforms-headers? headers-str) ;; raises a condition if it doesn't go well
|
||||
(let* ((hash (store-article-in-index! tmp mid)))
|
||||
(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 "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)))
|
||||
(t
|
||||
(handler-case
|
||||
(let* ((hash (store-article-in-index! tmp mid)))
|
||||
(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)))))))
|
||||
:data (fmt "Sorry. Your article doesn't conform: ~a." c)))
|
||||
(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>>=
|
||||
(defun conforms? (bs)
|
||||
(catch 'article-syntax-error
|
||||
(conforms-headers?
|
||||
(article-head (parse-article bs)))))
|
||||
<<Dead Does and article conform?.lisp>>=
|
||||
(defun conforms?-old (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 ((result (dolist (h (headers-required-from-clients))
|
||||
(when (not (lookup h headers))
|
||||
(return (fmt "missing the /~a/ header" h))))))
|
||||
(cond
|
||||
((stringp result) (values nil result))
|
||||
(t
|
||||
(let ((ngs (newsgroups-header->list (get-header "newsgroups" headers)))
|
||||
(ngs-dont-exist nil))
|
||||
(dolist (g ngs)
|
||||
(when (or (not (group-name-conforms? g))
|
||||
(not (group? g)))
|
||||
(push g ngs-dont-exist)))
|
||||
(if (not (zerop (length ngs-dont-exist)))
|
||||
(values nil (fmt "the ~a ~a just ~a exist"
|
||||
(word-plural (length ngs-dont-exist) "newsgroup")
|
||||
(str:join ", " (sort ngs-dont-exist #'string<))
|
||||
(word-plural (length ngs-dont-exist) "doesn't")))
|
||||
(values t nil)))))))))
|
||||
(let* ((headers (parse-headers headers-str))
|
||||
(missing (loop for h in (headers-required-from-clients)
|
||||
unless (lookup h headers)
|
||||
collect h)))
|
||||
(cond
|
||||
(missing (article-syntax-error!
|
||||
(fmt "missing the ~a ~a"
|
||||
(str:join ", " (mapcar (lambda (h) (fmt "/~a/" h)) missing))
|
||||
(word-plural (length missing) "header"))))
|
||||
(t
|
||||
(let ((ngs (newsgroups-header->list (get-header "newsgroups" headers)))
|
||||
(ngs-dont-exist nil))
|
||||
(dolist (g ngs)
|
||||
(when (or (not (group-name-conforms? g))
|
||||
(not (group? g)))
|
||||
(push g ngs-dont-exist)))
|
||||
(if (not (zerop (length ngs-dont-exist)))
|
||||
(article-syntax-error! (fmt "the ~a ~a just ~a exist"
|
||||
(word-plural (length ngs-dont-exist) "newsgroup")
|
||||
(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>>
|
||||
|
|
|
|||
|
|
@ -1,2 +1,2 @@
|
|||
(in-package :loop)
|
||||
(defparameter *git-hash* "d44771c")
|
||||
(defparameter *git-hash* "05be4aa")
|
||||
|
|
|
|||
Loading…
Reference in a new issue