diff --git a/loop.lisp b/loop.lisp index c8319b5..a6226bd 100644 --- a/loop.lisp +++ b/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))) diff --git a/loop.nw b/loop.nw index 93e52d4..087ee9a 100644 --- a/loop.nw +++ b/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} +<>= +(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 + +<>= +(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/ + <>= -(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 @ 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. -<>= +\begin{crossedblock} +<>= (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 }. It gets an +answer such as +% +\begin{verbatim} +xhdr references +221 Header information for references follows (from the article) + +. +\end{verbatim} +% +The client can now issue a {\tt HEAD} for each of these ones. + +<>= +(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. <>= (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)))))) @ <>= @@ -2046,7 +2309,7 @@ file next to it and atomically rename it into place. @ \begin{crossedblock} -<>= +<>= (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?]]. -<>= -(defun conforms? (bs) - (catch 'article-syntax-error - (conforms-headers? - (article-head (parse-article bs))))) +<>= +(defun conforms?-old (bs) + (conforms-headers? (article-head (parse-article bs)))) +@ +\end{crossedblock} +<>= (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} + +<>= +(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. <> <> <> +<> <> <> <> <> +<> <> <> <> diff --git a/version.lisp b/version.lisp index 057bbf0..e04af87 100644 --- a/version.lisp +++ b/version.lisp @@ -1,2 +1,2 @@ (in-package :loop) -(defparameter *git-hash* "d44771c") +(defparameter *git-hash* "05be4aa")