From 53072ef46fa1770267557ed107f61d7e5cbdfbb7 Mon Sep 17 00:00:00 2001 From: Circling Skies Date: Wed, 5 Aug 2026 16:04:42 -0300 Subject: [PATCH] Rewrites and presents the section on streaming articles to disk. --- loop.lisp | 632 +++++++++++++++++++++------------------------ loop.nw | 755 ++++++++++++++++++++++++------------------------------ 2 files changed, 632 insertions(+), 755 deletions(-) diff --git a/loop.lisp b/loop.lisp index 2bc444d..7eb7db1 100644 --- a/loop.lisp +++ b/loop.lisp @@ -27,7 +27,7 @@ (defparameter *default-database* nil) (defstruct command fn verb description) (defparameter *commands-assoc* nil) -(defstruct article headers body) +(defstruct article head body) (defparameter *months-inactive-allowed* 3) (defparameter *months-never-logged-in* 1) (defparameter *enable-nntp-repl* t) @@ -89,7 +89,7 @@ :data "unrecognized command" :request r)) :verb 'unrecognized - :description "a command for all commands typed wrong"))) + :description "a command for all commands typed wrongly"))) (or (cdr cmd) (unrecognized-command))))) (defmacro in-dir (dir &rest body) @@ -97,12 +97,14 @@ (uiop:with-current-directory (,dir) ,@body))) +(defmacro in-tmp (&rest body) `(in-dir "tmp/" ,@body)) + (defmacro in-groups (&rest body) `(in-dir "groups/" ,@body)) (defun in-group-lambda (g fn) (in-dir g (funcall fn))) (defmacro in-group (g &rest body) - `(in-group-lambda ,(fmt "groups/~a/" g) #'(lambda () ,@body))) + `(in-group-lambda (fmt "groups/~a/" ,g) #'(lambda () ,@body))) (defmacro with-group (g r &rest body) (let ((g-var (gensym)) @@ -111,7 +113,7 @@ (,r-var ,r)) (if (not (group? ,g-var)) (make-response :code 411 :request ,r-var - :data (format nil "no such group ``~a''" ,g-var)) + :data (fmt "no such group ``~a''" ,g-var)) (progn ,@body))))) (defmacro with-n-args (n r &rest body) @@ -187,7 +189,7 @@ (make-response :code (or code 400) :data msg :request r)) (defun integer->string (n) - (format nil "~a" n)) + (fmt "~a" n)) (defun mkstr (&rest args) ;; a utility (with-output-to-string (s) @@ -200,7 +202,7 @@ (vector 13 10)) (defun crlf-string () - (format nil "~c~c" #\return #\linefeed)) + (fmt "~c~c" #\return #\linefeed)) (defun flatten (obj) (do* ((result (list obj)) @@ -222,11 +224,6 @@ (let ((expr (read))) (if (eq 'quit expr) (progn - ;; At this point, there's \r\n still in the stdin due - ;; to read having returned a symbol followed by a line - ;; termination, so we must wipe that out or nntp-read-line - ;; will find an empty line after this. - (clear-input) (return (make-response :code 200 :request r @@ -253,33 +250,6 @@ :multi-line (response-multi-line r) :request (response-request r))) -(defun append-crlf-if-needed (seq) - (cond - ((stringp seq) - (append-crlf-if-needed (string->bytes seq))) - ((listp seq) - (append seq - (when (not (= (car (last seq)) 10)) - (list 13 10)))) - (t (error (format nil "append-crlf-if-needed: unsupported type: ~a" (type-of seq)))))) - -(defun send-response! (r) - ;; Write the response code and a space - (send-chunk! (integer->string (response-code r)) *standard-output*) - (send-chunk! " " *standard-output*) - ;; Write the actual payload (status text + article body) - (send-chunk! (response-data r) *standard-output*) - ;; Ensure a CRLF at the end of the payload - (send-chunk! (crlf) *standard-output*) - (when (response-multi-line r) - (send-chunk! "." *standard-output*) - (send-chunk! (crlf) *standard-output*)) - (force-output) - r) - -(defun my-write (ls-of-bytes s) - (write-sequence ls-of-bytes s)) - (defun parse-request (r) (let* ((collapsed-s (str:collapse-whitespaces (request-said r))) (ls (str:split " " collapsed-s :omit-nulls 'please))) @@ -466,19 +436,17 @@ (let ((pos (search #(13 10 13 10) v))) (if pos (make-article - :headers (map 'string #'code-char (subseq v 0 pos)) - ;; Create a zero-copy window into the original byte array. + :head (map 'string #'code-char (subseq v 0 pos)) :body (make-array (- (length v) (+ pos 4)) :element-type (array-element-type v) :displaced-to v :displaced-index-offset (+ pos 4))) - ;; What should we do if no body is found? Is that legal NNTP? (make-article - :headers (map 'string #'code-char v) + :head (map 'string #'code-char v) :body (make-array 0 :element-type (array-element-type v)))))) (defun hs-space-collapsed (hs) - (cl-ppcre:regex-replace-all (format nil "~a[ ~a]+" (crlf-string) #\tab) hs " ")) + (cl-ppcre:regex-replace-all (fmt "~a[ ~a]+" (crlf-string) #\tab) hs " ")) (defun hs-lines (lines) (str:split (crlf-string) lines)) @@ -487,10 +455,10 @@ (pos (search ":" h))) (when (null pos) (throw 'article-syntax-error - (values nil (format nil "missing colon in header |~a|" h)))) + (values nil (fmt "missing colon in header |~a|" h)))) (when (<= (length h) (+ 2 pos)) (throw 'article-syntax-error - (values nil (format nil "empty header ~a" h)))) + (values nil (fmt "empty header ~a" h)))) (multiple-value-bind (key val) (values (subseq h 0 pos) (subseq h (+ 2 pos))) (cons (str:downcase key) val)))) @@ -508,68 +476,88 @@ (defun fetch-headers (g i) (let* ((a-string (fetch-article g i)) (a-parsed (parse-article a-string)) - (headers (parse-headers (article-headers a-parsed)))) + (headers (parse-headers (article-head a-parsed)))) (enrich-headers headers a-string a-parsed))) (defun enrich-headers (hs a-raw a-parsed) (append hs - `(("line-count" . ,(format nil "~a" (nlines (article-body a-parsed)))) - ("byte-count" . ,(format nil "~a" (length a-raw)))))) + `(("line-count" . ,(fmt "~a" (nlines (article-body a-parsed)))) + ("byte-count" . ,(fmt "~a" (length a-raw)))))) (defun nlines (v) (loop for b across v count (= b 10))) -(defun read-headers-raw (path) - "Reads from PATH chunk by chunk until CRLF CRLF is found. - Returns the byte vector of the headers. Closes the file immediately." - (with-open-file (in path :element-type '(unsigned-byte 8) :if-does-not-exist nil) - (when in - (let ((acc (make-array 8192 :element-type '(unsigned-byte 8) - :adjustable t :fill-pointer 0)) - (buffer (make-array 8192 :element-type '(unsigned-byte 8))) - (delim #(13 10 13 10))) - (loop - (let ((n (read-sequence buffer in))) - (when (zerop n) - (return acc)) ; EOF reached without body delimiter - - ;; Append new bytes to our accumulator - (let ((start-search (length acc))) - (dotimes (i n) - (vector-push-extend (aref buffer i) acc)) - - ;; Search for the delimiter. We subtract 3 from our start - ;; index to catch delimiters that span across the chunk boundary. - (let ((pos (search delim acc :start2 (max 0 (- start-search 3))))) - (when pos - ;; Return exactly up to the end of the delimiter - (return (subseq acc 0 (+ pos 4)))))))))))) +(defun extract-mid (a) + (lookup "message-id" (parse-headers (article-head (parse-article a))))) +(defun lookup (key table) + (cdr (assoc key table :test #'string=))) (defstruct file-stream-payload (path "" :type string) (start-pos 0 :type integer)) (defun fetch-article (g i) - (in-groups - (read-headers-raw (format nil "~a/~a" g i)))) + (in-group g + (read-headers-raw (fmt "~a" i)))) -(defun read-file-raw (path) - (with-open-file - (in path - :element-type '(unsigned-byte 8) - :if-does-not-exist nil) +(defun read-headers-raw (path) + (with-open-file (in path :element-type '(unsigned-byte 8) :if-does-not-exist :error) (when in - (let* ((size (sb-posix:stat-size (sb-posix:stat path))) - (a (make-array size))) - (read-sequence a in) - a)))) + (let ((acc (make-array 8192 + :element-type '(unsigned-byte 8) + :adjustable t :fill-pointer 0)) + (buffer (make-array 8192 :element-type '(unsigned-byte 8))) + (sep #(13 10 13 10))) + (loop + (let ((n (read-sequence buffer in))) + (when (zerop n) + (return acc)) ; eof without having found the separator + (let ((start-search (length acc))) + (dotimes (i n) ; copy all bytes to the accumulator + (vector-push-extend (aref buffer i) acc)) + ;; Search for the separator. We subtract 3 from our + ;; start index to catch a separator that was broken into + ;; two calls of read-sequence. + (let ((pos (search sep acc :start2 (max 0 (- start-search 3))))) + (when pos + (return (subseq acc 0 (+ pos 4)))))))))))) -(defun extract-mid (a) - (lookup "message-id" (parse-headers (article-headers (parse-article a))))) +(defun stream-file-to-socket (payload out-stream) + "Opens the file, seeks to the start of the body, and streams to the socket + while applying on-the-fly NNTP dot-stuffing." + (with-open-file (in (file-stream-payload-path payload) + :element-type '(unsigned-byte 8)) + (file-position in (file-stream-payload-start-pos payload)) + (let ((buf (make-array 8192 :element-type '(unsigned-byte 8))) + (at-line-start t)) ; The body implicitly starts at the beginning of a line + (loop for n = (read-sequence buf in) + while (plusp n) + do (loop for i from 0 below n + for byte = (aref buf i) + do (when (and at-line-start (= byte 46)) ; 46 is '.' + (write-byte 46 out-stream)) + (write-byte byte out-stream) + (setf at-line-start (= byte 10))))))) -(defun lookup (key table) - (cdr (assoc key table :test #'string=))) +(defun send-chunk! (chunk s) + (etypecase chunk + (string (write-sequence (string->bytes chunk) s)) + (vector (write-sequence chunk s)) + (list (dolist (c chunk) (send-chunk! c s))) + (integer (write-byte chunk s)) + (file-stream-payload (stream-file-to-socket chunk s)))) + +(defun send-response! (r) + (send-chunk! (integer->string (response-code r)) *standard-output*) + (send-chunk! " " *standard-output*) + (send-chunk! (response-data r) *standard-output*) + (send-chunk! (crlf) *standard-output*) + (when (response-multi-line r) + (send-chunk! "." *standard-output*) + (send-chunk! (crlf) *standard-output*)) + (force-output) + r) (defun dispatch (r) (let* ((verb (request-verb r))) @@ -591,7 +579,7 @@ ((string= cmd "USER") (setf (client-username *client*) arg) (make-response :code 381 :request r - :data (format nil "Hey, ~a, please tell us your password." arg))) + :data (fmt "Hey, ~a, please tell us your password." arg))) ((string= cmd "PASS") (if (authinfo-check (client-username *client*) arg) (progn @@ -630,7 +618,7 @@ (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 (format nil "Unknown article ~a." n-or-mid)))))))) + (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) @@ -653,31 +641,31 @@ (defun typical-cmd-response (code r g i requested-part) (handler-case - (let* ((path (format nil "groups/~a/~a" g i)) + (let* ((path (fmt "groups/~a/~a" g i)) (headers-raw (read-headers-raw path))) (if (null headers-raw) - (make-response :code 400 :request r :data (format nil "article ~a/~a does not exist" g i)) + (make-response :code 400 :request r :data (fmt "article ~a/~a does not exist" g i)) (let* ((a (parse-article headers-raw)) ;; FIX: Pass the raw bytes to extract-mid, not the parsed struct (mid (extract-mid headers-raw)) (header-length (length headers-raw)) (payload (ecase requested-part - (:head (article-headers a)) + (:head (article-head a)) (:body (make-file-stream-payload :path path :start-pos header-length)) - (:article (list (article-headers a) + (:article (list (article-head a) + (crlf) (crlf) (make-file-stream-payload :path path :start-pos header-length)))))) - - (prepend-response-with (format nil "~a ~a" i mid) + (prepend-response-with (fmt "~a ~a" i mid) (make-response :multi-line 'yes :code code :request r :data payload))))) (sb-posix:syscall-error (c) - (let ((msg (format nil "article ~a/~a: ~a" g i c))) + (let ((msg (fmt "article ~a/~a: ~a" g i c))) (stderr msg) (make-response :code 400 :request r :data msg))) (error (c) - (let ((msg (format nil "unexpected condition when reading article ~a/~a: ~a" g i c))) + (let ((msg (fmt "unexpected condition when reading article ~a/~a: ~a" g i c))) (stderr msg) (make-response :code 400 :request r :data msg))))) @@ -697,7 +685,7 @@ (let ((cur (client-article *client*))) (make-response :code 223 :request r - :data (format nil "~a ~a" cur (mid-by-name g cur))))) + :data (fmt "~a ~a" cur (mid-by-name g cur))))) (defun mid-by-name (g name) (extract-mid (fetch-article g name))) @@ -744,7 +732,7 @@ (fetch-headers g i))))))))))) (defun xover-format-line (i hs) - (str:concat (format nil "~a~a" i #\tab) + (str:concat (fmt "~a~a" i #\tab) (str:join #\tab (mapcar #'(lambda (h) (get-header h hs)) (xover-headers))))) @@ -759,7 +747,7 @@ (with-group g r (set-group! g) (multiple-value-bind (low high len) (group-high-low g) - (let ((ln (format nil "~a ~a ~a ~a" len low high g))) + (let ((ln (fmt "~a ~a ~a ~a" len low high g))) (setf (client-article *client*) low) (make-response :code 211 :request r :data ln)))))))) @@ -767,9 +755,6 @@ (in-groups (ignore-errors (directory-p g)))) -(defun xgroup? (g) - (directory-p g)) - (defun set-group! (g) (setf (client-group *client*) g)) (defstruct group name high low) @@ -785,7 +770,7 @@ (reverse (mapcar #'(lambda (g) - (format nil "~a ~a ~a y" (group-name g) (group-high g) (group-low g))) + (fmt "~a ~a ~a y" (group-name g) (group-high g) (group-low g))) ls))) (defun build-groups-structs () @@ -891,22 +876,20 @@ (file-namestring s)))) (defun cmd-help (r) - (let ((lines (menu *commands-assoc*))) - (prepend-response-with - "What's on the menu today?" - (make-response :code 200 :multi-line 'yes - :request r - :data (str:join (crlf-string) lines))))) - -(defun menu (ls) - (loop for item in ls - collect (display-fn item))) - -(defun display-fn (cmd-pair) - (let ((cmd (cdr cmd-pair))) - (format nil "~A ~A" - (command-verb cmd) - (command-description cmd)))) + (labels ((menu (ls) + (loop for item in ls + collect (display-fn item))) + (display-fn (cmd-pair) + (let ((cmd (cdr cmd-pair))) + (fmt "~A ~A" + (command-verb cmd) + (command-description cmd))))) + (let ((lines (menu *commands-assoc*))) + (prepend-response-with + "What's on the menu today?" + (make-response :code 200 :multi-line 'yes + :request r + :data (str:join (crlf-string) lines)))))) (defun cmd-quit (r) (make-response :code 205 :data "Good-bye." :request r)) @@ -918,17 +901,22 @@ (format-timestring nil (now)))) (defun conforms? (bs) - (catch 'article-syntax-error ;; parse-headers might throw - (let ((headers (parse-headers (article-headers (parse-article bs))))) + "Convenience wrapper: parse the in-memory article and check headers." + (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 (format nil "missing the /~a/ header" h))))) - (content-type (get-header "content-type" headers))) - (cond + (return (fmt "missing the /~a/ header" h)))))) + (cond ((stringp result) (values nil result)) - ;((not (text/plain? content-type)) - ; (values nil (format nil "content-type must be plain/text, but it's ~a" content-type))) - (t + (t (let ((ngs (newsgroups-header->list (get-header "newsgroups" headers))) (ngs-dont-exist nil)) (dolist (g ngs) @@ -936,7 +924,7 @@ (not (group? g))) (push g ngs-dont-exist))) (if (not (zerop (length ngs-dont-exist))) - (values nil (format nil "the ~a ~a just ~a 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"))) @@ -955,7 +943,7 @@ '("from" "newsgroups" "subject")) (defun suggest-message-id (&optional (n 20)) - (format nil "<~a@loop>" (random-string n))) + (fmt "<~a@loop>" (random-string n))) (defun random-string (size) (let* ((universe "abcdefghijklmnopqrstuvwxyz") @@ -969,7 +957,7 @@ (defun unparse-article (parsed) ;; 1. Build the new headers as a standard string (let* ((headers-str (with-output-to-string (s) - (dolist (h (parse-headers (article-headers parsed))) + (dolist (h (parse-headers (article-head parsed))) (format s "~a: ~a~c~c" (str:capitalize (car h)) (cdr h) #\return #\linefeed)) ;; Add the final \r\n separating headers from the body (format s "~c~c" #\return #\linefeed))) @@ -979,19 +967,18 @@ :initial-contents (map 'list #'char-code headers-str))) ;; 3. Get the displaced, zero-copy body array (body-bytes (article-body parsed))) - ;; 4. Let SBCL compile this into a fast C-level memcpy (concatenate '(vector (unsigned-byte 8)) headers-bytes body-bytes))) (defun ensure-header (h fn bs) - (let* ((headers (parse-headers (article-headers (parse-article bs))))) + (let* ((headers (parse-headers (article-head (parse-article bs))))) (if (lookup h headers) bs (unparse-article (make-article - :headers + :head (str:join (crlf-string) (mapcar #'(lambda (h) - (format nil "~a: ~a" (car h) (cdr h))) + (fmt "~a: ~a" (car h) (cdr h))) (cons (cons h (funcall fn)) headers))) :body (article-body (parse-article bs))))))) @@ -999,7 +986,7 @@ (multiple-value-bind (s m h day mon year dow dst-p tz) (get-decoded-time) (declare (ignore dow dst-p)) - (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d GMT~a" + (fmt "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d GMT~a" year mon day h m s (- tz)))) (defun ensure-mid (bs) @@ -1009,31 +996,57 @@ (ensure-header "date" #'get-date bs)) (defun cmd-post (r) - (with-auth - (send-response! - (make-response - :code 340 - :data (format nil "Okay, go ahead. Suggested message-id ~a." - (suggest-message-id)))) - (let* ((bs (nntp-read-article))) - (multiple-value-bind (okay? error) (conforms? bs) - (cond ((not okay?) - (make-response - :code 400 :request r - :data (format nil "Sorry. Your article doesn't conform: ~a." error))) - (t (multiple-value-bind (code reply) (post bs) - (update-last-post-date! (client-username *client*)) - (make-response :code code :request r :data reply)))))))) + (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 "post-~a.tmp" (random-string 12)))) + (unwind-protect + (progn + (in-tmp (nntp-read-article-to-disk tmp)) + (stderr "finished writing article to disk in tmp/~a~%" tmp) + (let* ((headers-raw (in-tmp (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 (map 'string #'code-char + (subseq headers-raw 0 (max 0 (- (length headers-raw) 4)))))) + (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 + :code 400 :request r + :data (fmt "Sorry. Your article doesn't conform: ~a." error))) + (t + (multiple-value-bind (code reply) + (post tmp headers-raw) + (stderr "I'd post this article now.~%") + (update-last-post-date! (client-username *client*)) + (make-response :code code :request r :data reply))))))) + (ignore-errors (delete-file tmp))))))) -(defun post (bs) - (let* ((parsed (parse-article bs)) - (ngs (newsgroups-header->list - (get-header "newsgroups" (parse-headers (article-headers parsed))))) - (a (ensure-date (ensure-mid bs))) - (mid (extract-mid a))) +(defun post (tmp-path headers-raw) + (let* ((headers-str (map 'string #'code-char + (subseq headers-raw 0 (max 0 (- (length headers-raw) 4))))) + (headers (parse-headers headers-str)) + (ngs (newsgroups-header->list (get-header "newsgroups" headers))) + (body-start (length headers-raw))) + ;; This has gotten complicated. We need to move TMP-PATH into the + ;; first newsgroup and then symlink the article to all other + ;; groups. This means we give a different treatment to + ;; groups. This isn't so good. Looks like we should create a + ;; file-system index of articles and then symlink each article to + ;; each group---a more general treatment. Do this crazy thing now + ;; and then generalize only later once you've cleaned this code up + ;; so much. So here's your NEXT STEP: forget symlinks for now; + ;; copy the temporary article to each directory before you post + ;; it; IMPLEMENT COPY-TEMPORARY-FILE-TO and test the system. (dolist (ng ngs) - (save-article-insist ng (get-next-article-id ng) a mid)) - (values 240 (data "Thank you! Your article has been saved.")))) + (save-article-insist ng (get-next-article-id ng) tmp-path)) + (values 240 "Thank you! Your article has been saved."))) (defun newsgroups-header->list (s) (mapcar #'(lambda (n) (str:trim (string-downcase n))) (str:split "," s))) @@ -1043,57 +1056,63 @@ (setf (account-last-post u) (get-universal-time)))) (defun rename-no-extension (old new) - (rename-file old (make-pathname :name new :type :unspecific))) + (rename-file (merge-pathnames old (uiop:getcwd)) + (merge-pathnames (make-pathname :name new :type :unspecific) (uiop:getcwd)))) -(defun save-article-try (name-try bs) - (let ((name (format nil "~a" name-try)) - (tmp (format nil "~a.tmp" name-try))) - (with-open-file - (s name +(defun save-article-try (name-try src-path) + (stderr "going to try to save ~a with name ~a~%" src-path name-try) + (let ((name (fmt "~a" name-try)) + (tmp (fmt "~a.tmp" name-try))) + (with-open-file + (s name :direction :output - :if-exists nil ;; an atomic operation + :if-exists nil ; atomic O_EXCL allocation :if-does-not-exist :create) (when (null s) - (progn - (stderr "warning: save-article-try: ~a exists~%" name) - (return-from save-article-try 'name-exists)))) - (with-open-file - (s tmp - :direction :output - :if-exists :error - :if-does-not-exist :create - :element-type '(unsigned-byte 8)) - (write-sequence bs s)) - (rename-no-extension tmp name))) + (stderr "warning: save-article-try: ~a exists~%" name) + (return-from save-article-try 'name-exists))) + (stderr "going to rename in save-article-try~%") + ;; Because of my mess with directory paths, I'm having to do the + ;; ../../ here. This is bad design. We need to find a solution + ;; for this. But don't come up with the use + ;; absolute-paths-solution. Relative paths is always better. + (stderr "current-directory: ~a~%" (uiop:getcwd)) + (stderr "default-pathname: ~a~%" *default-pathname-defaults*) + (stderr "rename-no-extension ~a ~a~%" (fmt "tmp/~a" src-path) (fmt "groups/local.test/~a" name)) + (rename-no-extension (fmt "../../tmp/~a" src-path) name))) -(defun save-article-insist (g name a message-id) +(defun save-article-insist (g name src-path) (loop for name from name do - (in-dir (format nil "groups/~a/" g) - (when (not (eql 'name-exists (save-article-try name a))) - (return (values name (insert-index message-id g (fmt "~a" name)))))))) + (in-group g + (when (not (eql 'name-exists (save-article-try name src-path))) + (return (values name t)))))) (defun get-next-article-id (g) (multiple-value-bind (low high len) (group-high-low g) (declare (ignore low len)) (1+ high))) -(defun nntp-read-article () - ;; Returns a vector of bytes: the article, CRLF between lines, up to - ;; (excluding) the "." terminator. VECTOR-PUSH-EXTEND grows the - ;; buffer in amortized O(1) per push, so total cost is O(size of the - ;; article) rather than O([size of the article]^2). - (let ((buf (make-array 8192 +(defun nntp-read-article-to-disk (tmp-path) + "Streams an article to disk." + (let ((success nil)) + (with-open-file (out tmp-path + :direction :output :element-type '(unsigned-byte 8) - :adjustable t - :fill-pointer 0))) - (loop - (let ((ls (nntp-read-line))) - (stderr "nntp-read-line: [~A]" ls) - (when (eq ls :eof) (error 'end-of-file :stream *standard-input*)) - (when (end-of-article? ls) (return buf)) - (map nil (lambda (b) (vector-push-extend b buf)) ls) - (vector-push-extend 13 buf) - (vector-push-extend 10 buf))))) + :if-exists :error) + (loop + ;; 1. Fetch a clean line from your highly optimized buffer + (let ((line (nntp-read-line))) + ;(stderr "read line: ~a~%" line) + ;; 2. Detect terminator: A line containing exactly the byte 46 ('.') + (when (end-of-article? line) + (setf success t) + (return tmp-path)) + ;; 3. Dot-unstuffing: If the line starts with '.', skip the first byte + (let ((start-idx (if (and (> (length line) 0) (= (aref line 0) 46)) 1 0))) + (write-sequence line out :start start-idx))) + ;; 4. Restore the CRLF that `nntp-read-line` stripped away + (write-byte 13 out) + (write-byte 10 out))))) (defun end-of-article? (ls) ;; A line is the NNTP terminator only if it's exactly the single byte @@ -1145,62 +1164,10 @@ (extract-line lf-pos) (refill-and-extract-line)))))) -(defun nntp-read-line-buffered-old (stream buffer) - (let* ((data (nntp-stream-buffer-data buffer)) - (capacity (length data))) - (labels - ((find-lf (start end) - ;; remember that LF = byte 10 - (position 10 data :start start :end end)) - (extract-line (lf-pos) - (let* ((start (nntp-stream-buffer-head buffer)) - (end-line (if (and (> lf-pos start) - (= (aref data (1- lf-pos)) 13)) - (1- lf-pos) ; strip the preceding cr - lf-pos)) - (line (subseq data start end-line))) - (setf (nntp-stream-buffer-head buffer) (1+ lf-pos)) - line)) - (refill-and-extract-line () - (let* ((head (nntp-stream-buffer-head buffer)) - (tail (nntp-stream-buffer-tail buffer)) - (remaining (- tail head))) - (when (= remaining capacity) - (stderr "line too long in the network buffer: [~A]" - (subseq data head tail)) - (error "no space left on the network buffer for the current line")) - ;; There is space for more lines, but there's a - ;; partial line waiting to be completed, so we'll - ;; shift it to the begining of the buffer, so we can - ;; have more space (as %unix-read might produce more - ;; data below). - (when (> remaining 0) - (replace data data :start1 0 :start2 head :end2 tail)) - (setf (nntp-stream-buffer-head buffer) 0) - (setf (nntp-stream-buffer-tail buffer) remaining) - ;; Do the actual reading: we'll block until bytes - ;; arrive and return whatever the kernel has for us. - (let* ((n (%unix-read stream data remaining (- capacity remaining))) - (new-tail (+ remaining n))) - (setf (nntp-stream-buffer-tail buffer) new-tail) - (let ((lf-pos (find-lf remaining new-tail))) - (if lf-pos - (extract-line lf-pos) - (refill-and-extract-line))))))) ; Still no lf; keep reading. - ;; The main program - (let ((lf-pos (find-lf (nntp-stream-buffer-head buffer) - (nntp-stream-buffer-tail buffer)))) - (if lf-pos - (extract-line lf-pos) ; line already in buffer; no i/o at all - (refill-and-extract-line)))))) - (defun fetch-more-bytes (stream buf start max-count) - ;; Attempt the fast, native C-level POSIX read. If `fd-stream-of` - ;; fails to find an underlying file descriptor (e.g., SLIME REPL - ;; streams), it signals a TYPE-ERROR. We catch it and fallback. - - ;; This is kinda silly. Let's remove %portable-read because we - ;; really don't care about the SMILE REPL, though we use it. + "Try the fast POSIX path; fall back to a portable read-byte loop + when the stream has no underlying fd (Gray streams under SLIME, + string streams in tests, etc.)." (handler-case (%unix-read stream buf start max-count) (type-error () (%portable-read stream buf start max-count)))) @@ -1247,24 +1214,9 @@ "Peel away SYNONYM-STREAM and TWO-WAY-STREAM wrappers until we reach the underlying FD-STREAM. Signals a clear error if no FD-STREAM is found." (etypecase stream - (sb-sys:fd-stream stream) - (synonym-stream (fd-stream-of (symbol-value (synonym-stream-symbol stream)))) - (two-way-stream (fd-stream-of (two-way-stream-input-stream stream))))) - -(defun get-interactive-line (stream) - (let ((line-bytes - (make-array 0 - :element-type '(unsigned-byte 8) - :adjustable t :fill-pointer 0))) - (loop for byte = (read-byte stream) - while byte - do (vector-push-extend byte line-bytes) - (when (= byte 10) (loop-finish)) ; 10 means LF = \n - finally - (return - (if (zerop (length line-bytes)) - nil - line-bytes))))) + (sb-sys:fd-stream stream) + (synonym-stream (fd-stream-of (symbol-value (synonym-stream-symbol stream)))) + (two-way-stream (fd-stream-of (two-way-stream-input-stream stream))))) (defun list->bytes (ls) (mapcar #'data->bytes ls)) @@ -1273,43 +1225,12 @@ (mapcar #'data->bytes (coerce v 'list))) (defun data->bytes (d) - (cond ((null d) nil) - ((integerp d) (list d)) - ((stringp d) (string->bytes d)) - ((consp d) (list->bytes d)) - ((vectorp d) (vector->bytes d)) - (t (error (format nil "type ~a is not supported" (type-of d)))))) - -(defun send-chunk! (chunk s) - "Writes chunks sequentially to the stream." - (cond ((stringp chunk) - (my-write (string->bytes chunk) s)) - ((vectorp chunk) - (my-write chunk s)) - ((listp chunk) - (dolist (c chunk) - (send-chunk! c s))) - ((integerp chunk) - (write-byte chunk s)) - ((file-stream-payload-p chunk) - (stream-file-to-socket chunk s)))) - -(defun stream-file-to-socket (payload out-stream) - "Opens the file, seeks to the start of the body, and streams to the socket - while applying on-the-fly NNTP dot-stuffing." - (with-open-file (in (file-stream-payload-path payload) - :element-type '(unsigned-byte 8)) - (file-position in (file-stream-payload-start-pos payload)) - (let ((buf (make-array 8192 :element-type '(unsigned-byte 8))) - (at-line-start t)) ; The body implicitly starts at the beginning of a line - (loop for n = (read-sequence buf in) - while (plusp n) - do (loop for i from 0 below n - for byte = (aref buf i) - do (when (and at-line-start (= byte 46)) ; 46 is '.' - (write-byte 46 out-stream)) - (write-byte byte out-stream) - (setf at-line-start (= byte 10))))))) ; 10 is LF (\n) + (etypecase d + (null nil) + (integer (list d)) + (string (string->bytes d)) + (cons (list->bytes d)) + (vector (vector->bytes d)))) (defun add-crlf-between (ls-of-ls) ;; Add \r\n to each ``line''. Returns List-of Byte. @@ -1328,21 +1249,21 @@ (group-name-conforms? g) (if (not okay?) (make-response :code 580 :request r - :data (format nil "group name does not conform: ~a" reason)) + :data (fmt "group name does not conform: ~a" reason)) (progn (multiple-value-bind (path created?) (in-groups (ensure-directories-exist (concatenate 'string g "/"))) (declare (ignore created?)) (if (not path) (make-response :code 581 :request r - :data (format nil "could not create group ~a" + :data (fmt "could not create group ~a" (if (group? g) "because it already exists" "but we don't know why---sorry!"))) (progn (notify-group-created g) (make-response :code 280 :request r - :data (format nil "group ~a created" g))))))))))) + :data (fmt "group ~a created" g))))))))))) (defun group-name-conforms? (g) (conforms-to? g "^[^\\s/]+$")) @@ -1400,23 +1321,46 @@ (write-accounts!) (values (str:upcase username) p)))))) +(defmacro with-file-lock ((lock-path &key (sleep-time 0.1) (retries 50)) &body body) + (let ((lock-file (gensym "LOCK-FILE-")) + (stream (gensym "STREAM-")) + (attempt (gensym "ATTEMPT-"))) + `(let ((,lock-file ,lock-path)) + (unwind-protect + (progn + (loop for ,attempt from 1 to ,retries + do (handler-case + (with-open-file (,stream ,lock-file + :direction :output + :if-exists :error + :if-does-not-exist :create) + (format ,stream "~a~%" (get-universal-time)) + (return)) + (file-error () + (if (= ,attempt ,retries) + (error "could not acquire lock on ~a after ~a attempts." + ,lock-file ,retries) + (sleep ,sleep-time))))) + ,@body) + (ignore-errors (delete-file ,lock-file)))))) + (defun write-accounts! () - (let ((name - (loop + (with-file-lock ("accounts.lck") + (let ((name + (loop (let* ((tmp (random-string 10)) - (name (format nil "~a.tmp" tmp))) - (when - (ignore-errors - (with-open-file - (s name - :direction :output - :if-exists :error - :if-does-not-exist :create) - (write *accounts* :stream s))) + (name (fmt "~a.tmp" tmp))) + (when (ignore-errors + (with-open-file (s name + :direction :output + :if-exists :error + :if-does-not-exist :create) + (write *accounts* :stream s) + t)) (return name)))))) - (if (ignore-errors (rename-file name "accounts.lisp")) - (values t *accounts*) - (values nil (format nil "could not rename ~a to accounts.lisp" name))))) + (if (ignore-errors (rename-file name "accounts.lisp")) + (values t *accounts*) + (values nil (fmt "could not rename ~a to accounts.lisp" name)))))) (defun get-account (username) (loop for u in *accounts* @@ -1551,7 +1495,7 @@ (if s (universal-to-human s)))))) (defun cmd-dd (r) - (make-response :code 200 :data (format nil "state: ~a" *client*) :request r)) + (make-response :code 200 :data (fmt "state: ~a" *client*) :request r)) (defun cmd-repl (r) (if *enable-nntp-repl* @@ -1581,19 +1525,29 @@ (defun post-notification (&key subject body) (in-groups (ensure-directories-exist "local.control.news/")) (when (group? "local.control.news") - (let ((a (make-news :subject subject :body body))) - (post (concatenate 'vector (article-headers a) (crlf) (article-body a) (crlf)))))) - -(defun make-news (&key subject body) - (make-article - :headers (data - (add-crlf-between - (mapcar - #'(lambda (p) (data (format nil "~a: ~a" (car p) (cdr p)))) - `(("from" . "Loop") - ("subject" . ,subject) - ("newsgroups" . "local.control.news"))))) - :body (data body))) + (let ((tmp (fmt "notify-~a.tmp" (random-string 10))) + (mid (suggest-message-id))) + (unwind-protect + (progn + (with-open-file (out tmp + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede + :if-does-not-exist :create) + (flet ((wline (s) + (write-sequence (map 'vector #'char-code s) out) + (write-byte 13 out) (write-byte 10 out))) + (wline (fmt "From: Loop")) + (wline (fmt "Subject: ~a" subject)) + (wline (fmt "Newsgroups: local.control.news")) + (wline (fmt "Message-ID: ~a" mid)) + (wline (fmt "Date: ~a" (get-date))) + (write-byte 13 out) (write-byte 10 out) + (write-sequence (map 'vector #'char-code body) out) + (write-byte 13 out) (write-byte 10 out))) + (let ((headers-raw (read-headers-raw tmp))) + (post tmp headers-raw))) + (ignore-errors (delete-file tmp)))))) (defun cli/options () (list diff --git a/loop.nw b/loop.nw index bb27342..876b52b 100644 --- a/loop.nw +++ b/loop.nw @@ -402,21 +402,6 @@ since everyone can find a way to log in with anyone's account, change their passwords or just do whatever they want to \lxxp\ process or databases. -As the comment below explains, we need to [[clear-output]] in the -[[*standard-input*]] to avoid the following problem: -% -\begin{verbatim} -repl -LOOP> quit -200 Okay, no more REPL hacking. -400 I beg your pardon? -\end{verbatim} -% -What happens is that [[read]] consumes just the symbol \verb|quit|, so -there remains a \verb|\n| or \verb|\r\n| in the [[*standard-input*]], -which we need to wipe out, or [[nntp-read-line]] will consume an empty -line, which is what causes that 400 response. - <>= (defun repl (r) (in-package :loop) @@ -426,11 +411,6 @@ line, which is what causes that 400 response. (let ((expr (read))) (if (eq 'quit expr) (progn - ;; At this point, there's \r\n still in the stdin due - ;; to read having returned a symbol followed by a line - ;; termination, so we must wipe that out or nntp-read-line - ;; will find an empty line after this. - (clear-input) (return (make-response :code 200 :request r @@ -466,7 +446,7 @@ What does a client typically tell \lp? A client typically sends commands. Commands typically need arguments. Each command is dispatched to a procedure that answers it---it's the purpose of \verb|fn| in the command. Together, all commands make up a table of -commands, which is essentially what the user sees when ask for +commands, which is essentially what the user sees when asks for \verb|HELP|. (Be aware that some clients use the output of \verb|HELP|. For example, Gnus v5.13.) @@ -524,7 +504,7 @@ commands, which is essentially what the user sees when ask for :data "unrecognized command" :request r)) :verb 'unrecognized - :description "a command for all commands typed wrong"))) + :description "a command for all commands typed wrongly"))) (or (cdr cmd) (unrecognized-command))))) @ %def *commands-assoc* set-up-tables! get-command @@ -556,72 +536,18 @@ mark such responses with [[multi-line]]. :data (list message (crlf) (response-data r)) :multi-line (response-multi-line r) :request (response-request r))) -@ %def request response make-response make-request empty-response prepend-response-with - -Here's how to send a [[response]] to a client. - -<>= -(defun append-crlf-if-needed (seq) - (cond - ((stringp seq) - (append-crlf-if-needed (string->bytes seq))) - ((listp seq) - (append seq - (when (not (= (car (last seq)) 10)) - (list 13 10)))) - (t (error (format nil "append-crlf-if-needed: unsupported type: ~a" (type-of seq)))))) - -(defun send-response! (r) - ;; Write the response code and a space - (send-chunk! (integer->string (response-code r)) *standard-output*) - (send-chunk! " " *standard-output*) - ;; Write the actual payload (status text + article body) - (send-chunk! (response-data r) *standard-output*) - ;; Ensure a CRLF at the end of the payload - (send-chunk! (crlf) *standard-output*) - (when (response-multi-line r) - (send-chunk! "." *standard-output*) - (send-chunk! (crlf) *standard-output*)) - (force-output) - r) -@ %def send-response! - -{\bf XXX: dead paragraph}. (We're not running Windows anymore and -perhaps we're never going back to it? I believe this procedure could -be just the else clause. Check it and clean this up.) The Windows -Console---the one we use when we run {\tt cmd.exe}---makes the Lisp -procedure [[write-sequence]] produce UCS-2. Windows will do what we -need of [[write-sequence]] if we're not operating \lp\ on the Windows -Console. Recall that we do not run \lp\ on Windows Console, so -whatever happens because of it is of little importance to us. -However, we implement \lp\ on Windows and so it's convenient for us -that \lp\ and Windows play nicely with each other. A cheap solution -here is to simply convert the bytes to a string if \lp\ is directly -connected to an interactive Lisp stream. This way we effectively -eliminate the UCS-2 encoding used by Windows. It is perfectly fine -for us to destroy the encoding of articles while we're writing \Lp. -It is not fine, however, when it's running in production. But, in -production, {\tt (interactive-stream-p s)} will always be false. How -else should we handle this? - -<>= -(defun my-write (ls-of-bytes s) - (write-sequence ls-of-bytes s)) -@ %def my-write +@ \section{Main loop} -Every command consumes a [[request]] and produces a [[response]]. If -any procedure always produces a [[response]], then delivering a -[[response]] to the user is a matter of sending a string composed of -the [[response]] code concatenated with the [[response]] data. - -What does \lp\ do? It repetitively reads a line from the user, -processes that line and always replies something back. Then \lp\ is -back at waiting for the user to say something else again. If the user -says {\tt QUIT}, then we should identify it and terminate \lp's -execution. That's even [[send-response!]] returns the [[request]] -itself---so we can cascade actions based on a user's request. +Every command consumes a [[request]] and produces a [[response]]. +What does \lp\ do as its main loop? It repetitively reads a line from +the user, processes that line and always replies something back. Then +\lp\ is back at waiting for the user to say something else again. If +the user says {\tt QUIT}, then we should identify it and terminate +\lp's execution. That's why [[send-response!]] returns the + [[request]] itself---so we can cascade actions based on a user's + request. <
>= (defun main-loop () @@ -693,9 +619,9 @@ An NNTP server for a circle of friends. \section{Parsing of requests} -The commands themselves we call {\tt verbs} and everything else the -user types we call {\tt args}. Observe that upper and lower case -letters are equivalent in request verbs. +The commands themselves we call {\tt verbs}; everything else the user +types we call {\tt args}. Observe that upper and lower case letters +are equivalent in request verbs. <>= (defun parse-request (r) @@ -716,7 +642,7 @@ We're using the clingon library as per Vincent Dardel suggestion in ``The Common Lisp Cookbook''. We begin with writing a description of the program and options it understands. Notice I don't know how to support a two-argument option, so I hacked a solution away. What we -need to is to implement a new option. The library is extensible. +need to do is to implement a new option. The library is extensible. However, I could be misremembering it here, but I recall having decided to give up on the clingon library because it does too much. I think it even handles {\tt SIGINT} on our backs. Nevertheless, do @@ -876,43 +802,101 @@ has issued {\tt QUIT}, in which case we terminate [[main-loop]]. An article is made of two parts, the head and the body. We do need to parse the head, but we never parse the body: we don't want to intervene in anything that a user might be doing in the body of the -article. The headers, however, are mostly under the jurisdiction of -the server. This decision is due to the fact servers must read -headers. For example, how do we know to which groups an article was -posted? We look at the header {\tt newsgroups}. So, the server must -understand the encoding of headers. Therefore, we assume ASCII -encoding of all headers that we need to parse. +article; in fact, we don't need read the body in memory because it +might be large. When we need to send an article to a client, we then +read it chunk by chunk and stream it out with constant memory use. -The member [[headers]] of the structure [[article]] is just a string, -while body is a vector of bytes. To get a list of pairs out of the -set of all headers of an article, we can ask [[parse-headers]]. Yes, -I should've called the member [[headers]] as [[head]] and not -[[headers]] because both the word ``headers'' and its plural used here -suggest a list of parsed headers. We're going to rename this in due -time. %% TODO +The headers, however, are mostly under the jurisdiction of the server. +This assumption is justified by the fact that servers must understand +headers. For example, how do we know to which groups an article was +posted? We look at the header {\tt newsgroups}. The assumption we +make here is that headers are always one-byte encoded, which is not +the case of ASCII, but it is the case of ISO-8859-1. The procedure +[[code-char]] realizes this ideal, so we're out of trouble here. + +So, in the structure below, [[article-head]] is a string, while +[[article-body]] is a vector of bytes. To get a list of pairs out of +the set of all headers of an article, we can ask [[parse-headers]]. <>= -(defstruct article headers body) -@ +(defstruct article head body) +@ %def article-head article-body + +\section{How to extract articles from the database} + +We don't extract the entire article from the file system. We first +extract just the headers. If it's ever needed, we read the article +chunk by chunk and hand them to a client that asked for it. + +Let's focus now on reading the headers. First, we need to read the +bytes off of the file system into memory. What if the article is +huge? We can't read it all. What we do is to read just enough of the +article until we find all of the head. That's the job of +[[read-headers-raw]]. + +The method below is to assume every head fits in a certain fixed size. +We'll be right nearly 100\% of the time. If we were to find a very +long head, we'll then allocate more and more and crash, which is fine +because a \lp\ process handles just a single client. Ideally, we'd +stop at a certain limit and give up on the article, which is easy to +do: throw an exception if the size of the array goes beyond the limit. + +We work with two buffers, the accumulator [[acc]] and the temporary +[[buffer]]. We fill in [[buffer]]. Now we memorize the length of +[[acc]] before we possibly modify its size by copying-extending it. +Now we know the position of where the new chunk of the head has been +allocated. It's time to search just the newly-read chunk for +\verb|\r\n\r\n|. A [[search]] call should do. However, what happens +if a chunk read from the stream ended right in the middle of the +separator? We would be appending the tail of the separator right now, +so we must go back a little bit before we search so that we can find +the separator even in cases when we had to read it in two calls to +[[read-sequence]]. (Such is life in programming.) That's why we +subtract 3 from [[start-search]]. If we don't find the separator +still, that's because the head is really long, so we repeat. When we +found it, we know that the head starts at zero and goes up to the +position of the separator plus the four bytes of the separator itself. +Why do we include the four bytes in the head? That makes it easy +later one to know where we would find the body---exactly after where +the head ends. + +\section{How to parse articles} + +Let's now describe how we implement the parsing of articles. 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. + +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 +empty body if no separator could ever be found. While \Lp would never +create such an article, it could be tomorrow that we might parse +foreign articles for whatever reason. <>= (defun parse-article (v) (let ((pos (search #(13 10 13 10) v))) (if pos (make-article - :headers (map 'string #'code-char (subseq v 0 pos)) - ;; Create a zero-copy window into the original byte array. + :head (map 'string #'code-char (subseq v 0 pos)) :body (make-array (- (length v) (+ pos 4)) :element-type (array-element-type v) :displaced-to v :displaced-index-offset (+ pos 4))) - ;; What should we do if no body is found? Is that legal NNTP? (make-article - :headers (map 'string #'code-char v) + :head (map 'string #'code-char v) :body (make-array 0 :element-type (array-element-type v)))))) (defun hs-space-collapsed (hs) - (cl-ppcre:regex-replace-all (format nil "~a[ ~a]+" (crlf-string) #\tab) hs " ")) + (cl-ppcre:regex-replace-all (fmt "~a[ ~a]+" (crlf-string) #\tab) hs " ")) (defun hs-lines (lines) (str:split (crlf-string) lines)) @@ -921,10 +905,10 @@ time. %% TODO (pos (search ":" h))) (when (null pos) (throw 'article-syntax-error - (values nil (format nil "missing colon in header |~a|" h)))) + (values nil (fmt "missing colon in header |~a|" h)))) (when (<= (length h) (+ 2 pos)) (throw 'article-syntax-error - (values nil (format nil "empty header ~a" h)))) + (values nil (fmt "empty header ~a" h)))) (multiple-value-bind (key val) (values (subseq h 0 pos) (subseq h (+ 2 pos))) (cons (str:downcase key) val)))) @@ -937,7 +921,8 @@ time. %% TODO @ %def parse-article parse-headers We now write some procedures that we use when we're build the {\em - overview} of the command \verb|XOVER|. + overview} of the command \verb|XOVER|. We write them here because +they're still part of parsing an article. <>= (defun get-header (key hs) @@ -947,121 +932,188 @@ We now write some procedures that we use when we're build the {\em (defun fetch-headers (g i) (let* ((a-string (fetch-article g i)) (a-parsed (parse-article a-string)) - (headers (parse-headers (article-headers a-parsed)))) + (headers (parse-headers (article-head a-parsed)))) (enrich-headers headers a-string a-parsed))) (defun enrich-headers (hs a-raw a-parsed) (append hs - `(("line-count" . ,(format nil "~a" (nlines (article-body a-parsed)))) - ("byte-count" . ,(format nil "~a" (length a-raw)))))) + `(("line-count" . ,(fmt "~a" (nlines (article-body a-parsed)))) + ("byte-count" . ,(fmt "~a" (length a-raw)))))) (defun nlines (v) (loop for b across v count (= b 10))) @ %def get-header fetch-headers -\section{How to extract articles from the database} - -Notice that we do not care about which encoding is used in articles. -We just read the article bytes and handle them to the client. It's -the article viewer's---the NNTP client's, that is---responsibility of -interpreting such bytes. That's why we call [[read-sequence]] here. +The procedures [[extract-mid]] and [[lookup]] also belong belong in +this section. Do they really? It seems so. <>= -(defun read-headers-raw (path) - "Reads from PATH chunk by chunk until CRLF CRLF is found. - Returns the byte vector of the headers. Closes the file immediately." - (with-open-file (in path :element-type '(unsigned-byte 8) :if-does-not-exist nil) - (when in - (let ((acc (make-array 8192 - :element-type '(unsigned-byte 8) - :adjustable t :fill-pointer 0)) - (buffer (make-array 8192 :element-type '(unsigned-byte 8))) - (delim #(13 10 13 10))) - (loop - (let ((n (read-sequence buffer in))) - (when (zerop n) - (return acc)) ; EOF reached without body delimiter - - ;; Append new bytes to our accumulator - (let ((start-search (length acc))) - (dotimes (i n) - (vector-push-extend (aref buffer i) acc)) - - ;; Search for the delimiter. We subtract 3 from our start - ;; index to catch delimiters that span across the chunk boundary. - (let ((pos (search delim acc :start2 (max 0 (- start-search 3))))) - (when pos - ;; Return exactly up to the end of the delimiter - (return (subseq acc 0 (+ pos 4)))))))))))) +(defun extract-mid (a) + (lookup "message-id" (parse-headers (article-head (parse-article a))))) +(defun lookup (key table) + (cdr (assoc key table :test #'string=))) +@ %def extract-mid lookup +\section{How to stream off articles through the network} + +We consider the body of articles to be the poster's property, so we +don't want to touch it in any way. For example, we never treat it as +a string because we would have to guess an encoding. It's the article +viewer's---the NNTP client's---responsibility of interpreting such +bytes. + +For us, articles are made of a string head and a sequence-of-bytes +body. Of great relevance is the fact that some articles could be +huge, so we don't read them wholly into memory. When it's necessary +to send an entire article to a client, we just stream the bytes to the +client chunk by chunk, giving us a constant-memory guarantee. We +describe now how we do this. + +You can see in [[parse-article]] that we use a {\em displaced array}. +A displaced array is a great feature of Common Lisp in which a new +array is made but references an already allocated memory. How are +articles handled by LOOP? Begin at [[fetch-article]], which depends +on [[read-headers-raw]], a procedure that reads only so much of an +article so as to consume the entirety of headers, using +[[vector-push-extend]]. So the way only to attack LOOP is to send it +an article whose headers are huge, implying we must limit article's +head size, though we don't currently do that. As soon as headers are +consumed, [[read-headers-raw]] finishes. + +Of greater relevance here is [[typical-cmd-response]] because it is +the one that actually streams off bytes to a client. How does it do +it? It first reads the headers and then it marks off where the body +begins. How does it mark the body? By using the structure called +[[file-stream-payload]], our choice of how to represent an article +body. The structure records the path of the file and where in the +streaming it is; the {\em where} is the current byte to be written to +the network, discovered by Lisp's [[file-position]], the portable +version of [[POSIX fseek]]. Where does a body begin? An article is +made of a head, a separator and a body. So the body begins at the +separator ends. You can verify this information by reading +[[read-headers-raw]]; notice how it returns the head by adding 4 bytes +after the position of where the separator was found---in other words, +the head includes the separator, so the body begins right where +[[read-headers-raw]] ends. + +The product of [[typical-cmd-response]] is a response. When an entire +article has been requested---which is what happens when someone issues +a [[BODY]] or an [[ARTICLE]] command---, [[send-response!]] will need +to read the body's bytes. If you now look at [[send-response!]] you +can see that it delegates the actual work to [[send-chunk!]], which, +in turn, delegates it to [[stream-file-to-socket]], which does the +job. How does it do the job? It knows exactly where the body begins. +It then has only the job of reading a chunk (of fixed sized) of that +file at where the body begins. Then it writes the entire file to the +client's network connection. How does it do it? While it's able to +get bytes from [[read-sequence]], it writes them one by one to the +network socket. Why one one by one? To make sure we can do {\em + dot-stuffing}, otherwise we could've delegated that job to +[[write-sequence]]. + +Can we do a better job with respect to the source code writing? Not +really. Procedure [[send-response!]] needs to do different things +based on the type of content. This desired type-dispatching is +performed by [[send-chunk!]] and then we need to write a particular +procedure for handling the file-stream-payload representation. + +{\bf Dot stuffing}. Should dot stuffing be done on the fly? The +alternative would be when storing the article. But, no, we should +store the article precisely as the user has sent it. It is to be +treated as an important historical document. We don't touch user +property, which is the article's body. + +<>= (defstruct file-stream-payload (path "" :type string) (start-pos 0 :type integer)) (defun fetch-article (g i) - (in-groups - (read-headers-raw (format nil "~a/~a" g i)))) + (in-group g + (read-headers-raw (fmt "~a" i)))) -(defun read-file-raw (path) - (with-open-file - (in path - :element-type '(unsigned-byte 8) - :if-does-not-exist nil) +(defun read-headers-raw (path) + (with-open-file (in path :element-type '(unsigned-byte 8) :if-does-not-exist :error) (when in - (let* ((size (sb-posix:stat-size (sb-posix:stat path))) - (a (make-array size))) - (read-sequence a in) - a)))) -@ %def fetch-article + (let ((acc (make-array 8192 + :element-type '(unsigned-byte 8) + :adjustable t :fill-pointer 0)) + (buffer (make-array 8192 :element-type '(unsigned-byte 8))) + (sep #(13 10 13 10))) + (loop + (let ((n (read-sequence buffer in))) + (when (zerop n) + (return acc)) ; eof without having found the separator + (let ((start-search (length acc))) + (dotimes (i n) ; copy all bytes to the accumulator + (vector-push-extend (aref buffer i) acc)) + ;; Search for the separator. We subtract 3 from our + ;; start index to catch a separator that was broken into + ;; two calls of read-sequence. + (let ((pos (search sep acc :start2 (max 0 (- start-search 3))))) + (when pos + (return (subseq acc 0 (+ pos 4)))))))))))) -The procedures [[extract-mid]] and [[lookup]] also belong belong in -this section. Notice that I also wrote [[mid-by-name]], which should -merge with [[extract-mid]]. I think I also wrote more -redundancies---perhaps in the implementatio nof [[xover]]---for not -using [[lookup]]. I need to seek out all such places and organize. %% TODO +(defun stream-file-to-socket (payload out-stream) + "Opens the file, seeks to the start of the body, and streams to the socket + while applying on-the-fly NNTP dot-stuffing." + (with-open-file (in (file-stream-payload-path payload) + :element-type '(unsigned-byte 8)) + (file-position in (file-stream-payload-start-pos payload)) + (let ((buf (make-array 8192 :element-type '(unsigned-byte 8))) + (at-line-start t)) ; The body implicitly starts at the beginning of a line + (loop for n = (read-sequence buf in) + while (plusp n) + do (loop for i from 0 below n + for byte = (aref buf i) + do (when (and at-line-start (= byte 46)) ; 46 is '.' + (write-byte 46 out-stream)) + (write-byte byte out-stream) + (setf at-line-start (= byte 10))))))) -<>= -(defun extract-mid (a) - (lookup "message-id" (parse-headers (article-headers (parse-article a))))) -(defun lookup (key table) - (cdr (assoc key table :test #'string=))) -@ %def extract-mid lookup +(defun send-chunk! (chunk s) + (etypecase chunk + (string (write-sequence (string->bytes chunk) s)) + (vector (write-sequence chunk s)) + (list (dolist (c chunk) (send-chunk! c s))) + (integer (write-byte chunk s)) + (file-stream-payload (stream-file-to-socket chunk s)))) + +(defun send-response! (r) + (send-chunk! (integer->string (response-code r)) *standard-output*) + (send-chunk! " " *standard-output*) + (send-chunk! (response-data r) *standard-output*) + (send-chunk! (crlf) *standard-output*) + (when (response-multi-line r) + (send-chunk! "." *standard-output*) + (send-chunk! (crlf) *standard-output*)) + (force-output) + r) +@ %def read-headers-raw fetch-article file-stream-payload \section{Commands} \subsection{{\tt HELP}} -When someone asks for help, we present a table of commands. The table -construction is made by [[menu]]. The procedure [[menu]] was one of -the first things I wrote. (This is my first program written in Common -Lisp.) I didn't want to get involved with the famous [[loop]] macro, -so I used recursion in [[menu]]\footnote{I'd like to isolate these -auxiliary procedures inside a single function that uses them. Common -Lisp offers me [[labels]], but [[labels]] don't seem so helpful when -I'm at the REPL. When I use [[defun]], I'm able to always invoke the -procedure at the REPL, but that's not so with [[labels]]. I guess the -use of [[labels]] is when the procedure is so trivial that we have no -reason to think we're doing to debug it.} +When someone asks for help, we present a table of commands. <>= (defun cmd-help (r) - (let ((lines (menu *commands-assoc*))) - (prepend-response-with - "What's on the menu today?" - (make-response :code 200 :multi-line 'yes - :request r - :data (str:join (crlf-string) lines))))) - -(defun menu (ls) - (loop for item in ls - collect (display-fn item))) - -(defun display-fn (cmd-pair) - (let ((cmd (cdr cmd-pair))) - (format nil "~A ~A" - (command-verb cmd) - (command-description cmd)))) + (labels ((menu (ls) + (loop for item in ls + collect (display-fn item))) + (display-fn (cmd-pair) + (let ((cmd (cdr cmd-pair))) + (fmt "~A ~A" + (command-verb cmd) + (command-description cmd))))) + (let ((lines (menu *commands-assoc*))) + (prepend-response-with + "What's on the menu today?" + (make-response :code 200 :multi-line 'yes + :request r + :data (str:join (crlf-string) lines)))))) @ \subsection{{\tt AUTHINFO}}\label{sec:authinfo} @@ -1091,7 +1143,7 @@ Syntax error. Say ``authinfo USER /your-name/'' then ``authinfo PASS /your-pass/ ((string= cmd "USER") (setf (client-username *client*) arg) (make-response :code 381 :request r - :data (format nil "Hey, ~a, please tell us your password." arg))) + :data (fmt "Hey, ~a, please tell us your password." arg))) ((string= cmd "PASS") (if (authinfo-check (client-username *client*) arg) (progn @@ -1202,26 +1254,49 @@ the problem? Two processes in parallel may ask for the writing of modifications lost. What do we need to do? Either we use file locking or we do something smarter without a real file locking mechanism. It's not clear to me what is possible here, but this is -definitely a problem that we need to solve. +definitely a problem that we need to solve. I think we need locking. <>= +(defmacro with-file-lock ((lock-path &key (sleep-time 0.1) (retries 50)) &body body) + (let ((lock-file (gensym "LOCK-FILE-")) + (stream (gensym "STREAM-")) + (attempt (gensym "ATTEMPT-"))) + `(let ((,lock-file ,lock-path)) + (unwind-protect + (progn + (loop for ,attempt from 1 to ,retries + do (handler-case + (with-open-file (,stream ,lock-file + :direction :output + :if-exists :error + :if-does-not-exist :create) + (format ,stream "~a~%" (get-universal-time)) + (return)) + (file-error () + (if (= ,attempt ,retries) + (error "could not acquire lock on ~a after ~a attempts." + ,lock-file ,retries) + (sleep ,sleep-time))))) + ,@body) + (ignore-errors (delete-file ,lock-file)))))) + (defun write-accounts! () - (let ((name - (loop + (with-file-lock ("accounts.lck") + (let ((name + (loop (let* ((tmp (random-string 10)) - (name (format nil "~a.tmp" tmp))) - (when - (ignore-errors - (with-open-file - (s name - :direction :output - :if-exists :error - :if-does-not-exist :create) - (write *accounts* :stream s))) + (name (fmt "~a.tmp" tmp))) + (when (ignore-errors + (with-open-file (s name + :direction :output + :if-exists :error + :if-does-not-exist :create) + (write *accounts* :stream s) + t)) (return name)))))) - (if (ignore-errors (rename-file name "accounts.lisp")) - (values t *accounts*) - (values nil (format nil "could not rename ~a to accounts.lisp" name))))) + (if (ignore-errors (rename-file name "accounts.lisp")) + (values t *accounts*) + (values nil (fmt "could not rename ~a to accounts.lisp" name)))))) (defun get-account (username) (loop for u in *accounts* @@ -1412,7 +1487,7 @@ even cache the overview of the group.) %% TODO (reverse (mapcar #'(lambda (g) - (format nil "~a ~a ~a y" (group-name g) (group-high g) (group-low g))) + (fmt "~a ~a ~a y" (group-name g) (group-high g) (group-low g))) ls))) (defun build-groups-structs () @@ -1553,7 +1628,7 @@ We just need to verify if the group exists and modify [[*client*]]. (with-group g r (set-group! g) (multiple-value-bind (low high len) (group-high-low g) - (let ((ln (format nil "~a ~a ~a ~a" len low high g))) + (let ((ln (fmt "~a ~a ~a ~a" len low high g))) (setf (client-article *client*) low) (make-response :code 211 :request r :data ln)))))))) @@ -1561,16 +1636,10 @@ We just need to verify if the group exists and modify [[*client*]]. (in-groups (ignore-errors (directory-p g)))) -(defun xgroup? (g) - (directory-p g)) - (defun set-group! (g) (setf (client-group *client*) g)) @ %def group? -Why have I written {\tt group?} and {\tt xgroup?}? There's probably a -clean-up task here. %% TODO - \subsection{{\tt BODY}, {\tt HEAD}, {\tt ARTICLE} e {\tt NEXT}} \label{sec:typical-cmds} @@ -1598,7 +1667,7 @@ Section~\ref{sec:index} for the implementation of the index. (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 (format nil "Unknown article ~a." n-or-mid)))))))) + (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) @@ -1638,31 +1707,31 @@ not ignoring any errors at all. <>= (defun typical-cmd-response (code r g i requested-part) (handler-case - (let* ((path (format nil "groups/~a/~a" g i)) + (let* ((path (fmt "groups/~a/~a" g i)) (headers-raw (read-headers-raw path))) (if (null headers-raw) - (make-response :code 400 :request r :data (format nil "article ~a/~a does not exist" g i)) + (make-response :code 400 :request r :data (fmt "article ~a/~a does not exist" g i)) (let* ((a (parse-article headers-raw)) ;; FIX: Pass the raw bytes to extract-mid, not the parsed struct (mid (extract-mid headers-raw)) (header-length (length headers-raw)) (payload (ecase requested-part - (:head (article-headers a)) + (:head (article-head a)) (:body (make-file-stream-payload :path path :start-pos header-length)) - (:article (list (article-headers a) + (:article (list (article-head a) + (crlf) (crlf) (make-file-stream-payload :path path :start-pos header-length)))))) - - (prepend-response-with (format nil "~a ~a" i mid) + (prepend-response-with (fmt "~a ~a" i mid) (make-response :multi-line 'yes :code code :request r :data payload))))) (sb-posix:syscall-error (c) - (let ((msg (format nil "article ~a/~a: ~a" g i c))) + (let ((msg (fmt "article ~a/~a: ~a" g i c))) (stderr msg) (make-response :code 400 :request r :data msg))) (error (c) - (let ((msg (format nil "unexpected condition when reading article ~a/~a: ~a" g i c))) + (let ((msg (fmt "unexpected condition when reading article ~a/~a: ~a" g i c))) (stderr msg) (make-response :code 400 :request r :data msg))))) @ %def typical-cmd-response @@ -1686,7 +1755,7 @@ The command \verb|NEXT| has a slight different semantics. (let ((cur (client-article *client*))) (make-response :code 223 :request r - :data (format nil "~a ~a" cur (mid-by-name g cur))))) + :data (fmt "~a ~a" cur (mid-by-name g cur))))) (defun mid-by-name (g name) (extract-mid (fetch-article g name))) @@ -1742,7 +1811,7 @@ to the last one. :test #'string=)) (fetch-headers g i))))))))))) (defun xover-format-line (i hs) - (str:concat (format nil "~a~a" i #\tab) + (str:concat (fmt "~a~a" i #\tab) (str:join #\tab (mapcar #'(lambda (h) (get-header h hs)) (xover-headers))))) @@ -1791,7 +1860,7 @@ I'm going to remove this very soon. <>= (defun cmd-dd (r) - (make-response :code 200 :data (format nil "state: ~a" *client*) :request r)) + (make-response :code 200 :data (fmt "state: ~a" *client*) :request r)) @ %def \subsection{{\tt POST}}\label{sec:post} @@ -1807,7 +1876,7 @@ must have \verb|message-id|, \verb|subject|, \verb|from|, <>= <> (defun suggest-message-id (&optional (n 20)) - (format nil "<~a@loop>" (random-string n))) + (fmt "<~a@loop>" (random-string n))) (defun random-string (size) (let* ((universe "abcdefghijklmnopqrstuvwxyz") @@ -1827,7 +1896,7 @@ now is not the time for fixing this. (defun unparse-article (parsed) ;; 1. Build the new headers as a standard string (let* ((headers-str (with-output-to-string (s) - (dolist (h (parse-headers (article-headers parsed))) + (dolist (h (parse-headers (article-head parsed))) (format s "~a: ~a~c~c" (str:capitalize (car h)) (cdr h) #\return #\linefeed)) ;; Add the final \r\n separating headers from the body (format s "~c~c" #\return #\linefeed))) @@ -1837,7 +1906,6 @@ now is not the time for fixing this. :initial-contents (map 'list #'char-code headers-str))) ;; 3. Get the displaced, zero-copy body array (body-bytes (article-body parsed))) - ;; 4. Let SBCL compile this into a fast C-level memcpy (concatenate '(vector (unsigned-byte 8)) headers-bytes body-bytes))) @ %def unparse-article @@ -1849,15 +1917,15 @@ now, however, we have only these two to worry about. <>= (defun ensure-header (h fn bs) - (let* ((headers (parse-headers (article-headers (parse-article bs))))) + (let* ((headers (parse-headers (article-head (parse-article bs))))) (if (lookup h headers) bs (unparse-article (make-article - :headers + :head (str:join (crlf-string) (mapcar #'(lambda (h) - (format nil "~a: ~a" (car h) (cdr h))) + (fmt "~a: ~a" (car h) (cdr h))) (cons (cons h (funcall fn)) headers))) :body (article-body (parse-article bs))))))) @@ -1865,7 +1933,7 @@ now, however, we have only these two to worry about. (multiple-value-bind (s m h day mon year dow dst-p tz) (get-decoded-time) (declare (ignore dow dst-p)) - (format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d GMT~a" + (fmt "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d GMT~a" year mon day h m s (- tz)))) (defun ensure-mid (bs) @@ -1899,8 +1967,8 @@ of trying to stop them. (send-response! (make-response :code 340 - :data (format nil "Okay, go ahead. Suggested message-id ~a." suggested))) - (let ((tmp (format nil "post-~a.tmp" (random-string 12)))) + :data (fmt "Okay, go ahead. Suggested message-id ~a." suggested))) + (let ((tmp (fmt "post-~a.tmp" (random-string 12)))) (unwind-protect (progn (in-tmp (nntp-read-article-to-disk tmp)) @@ -1917,7 +1985,7 @@ of trying to stop them. ((not okay?) (make-response :code 400 :request r - :data (format nil "Sorry. Your article doesn't conform: ~a." error))) + :data (fmt "Sorry. Your article doesn't conform: ~a." error))) (t (multiple-value-bind (code reply) (post tmp headers-raw) @@ -1984,8 +2052,8 @@ file next to it and atomically rename it into place. (defun save-article-try (name-try src-path) (stderr "going to try to save ~a with name ~a~%" src-path name-try) - (let ((name (format nil "~a" name-try)) - (tmp (format nil "~a.tmp" name-try))) + (let ((name (fmt "~a" name-try)) + (tmp (fmt "~a.tmp" name-try))) (with-open-file (s name :direction :output @@ -2034,103 +2102,6 @@ lines. Otherwise, we continue by attaching the new line to the end of our accumulated list of lines. <>= -(defun nntp-read-line-buffered (stream buffer) - (let* ((data (nntp-stream-buffer-data buffer)) - (capacity (length data))) - (labels - ((find-lf (start end) - (position 10 data :start start :end end)) - (extract-line (lf-pos) - (let* ((start (nntp-stream-buffer-head buffer)) - (end-line (if (and (> lf-pos start) - (= (aref data (1- lf-pos)) 13)) - (1- lf-pos) ; strip the preceding cr - lf-pos)) - (line (subseq data start end-line))) - (setf (nntp-stream-buffer-head buffer) (1+ lf-pos)) - line)) - (refill-and-extract-line () - (let* ((head (nntp-stream-buffer-head buffer)) - (tail (nntp-stream-buffer-tail buffer)) - (remaining (- tail head))) - (when (= remaining capacity) - (stderr "line too long in the network buffer: [~A]" - (subseq data head tail)) - (error "no space left on the network buffer for the current line")) - ;; There is space for more lines, but there's a - ;; partial line waiting to be completed, so we'll - ;; shift it to the begining of the buffer, so we can - ;; have more space (as fetch-more-bytes might produce - ;; more data below). - (when (> remaining 0) - (replace data data :start1 0 :start2 head :end2 tail)) - (setf (nntp-stream-buffer-head buffer) 0) - (setf (nntp-stream-buffer-tail buffer) remaining) - ;; Do the actual reading: we'll block until bytes - ;; arrive and return whatever's available for us, - ;; regardless of which mechanism fetched it. - (let* ((n (fetch-more-bytes stream data remaining (- capacity remaining))) - (new-tail (+ remaining n))) - (setf (nntp-stream-buffer-tail buffer) new-tail) - (let ((lf-pos (find-lf remaining new-tail))) - (if lf-pos - (extract-line lf-pos) - (refill-and-extract-line))))))) ; Still no lf; keep reading. - ;; The main program - (let ((lf-pos (find-lf (nntp-stream-buffer-head buffer) - (nntp-stream-buffer-tail buffer)))) - (if lf-pos - (extract-line lf-pos) ; line already in buffer; no i/o at all - (refill-and-extract-line)))))) - -(defun fetch-more-bytes (stream buf start max-count) - "Fetches at least one more byte into BUF at START (up to MAX-COUNT). -Tries the fast fd-based %UNIX-READ first; falls back to %PORTABLE-READ -for streams FD-STREAM-OF can't resolve to a raw fd, e.g. a Swank/SLIME -REPL connection. Only a missing fd triggers the fallback -- a real -disconnect still signals END-OF-FILE straight through, uncaught." - (handler-case (%unix-read stream buf start max-count) - (type-error () (%portable-read stream buf start max-count)))) - -(defun %unix-read (stream buf start max-count) - ;;; One POSIX read(2) on STREAM's underlying fd. - ;;; - ;;; Blocks until at least one byte arrives, then returns immediately with - ;;; however many bytes the kernel has buffered (up to MAX-COUNT). - ;;; Retries transparently on EINTR (signals can interrupt system calls). - ;;; Signals END-OF-FILE when the peer closes the connection. - (let ((fd (sb-sys:fd-stream-fd (fd-stream-of stream)))) - (sb-sys:with-pinned-objects (buf) - (loop - (multiple-value-bind (n err) - (sb-unix:unix-read fd - (sb-sys:sap+ (sb-sys:vector-sap buf) start) - max-count) - (cond - ((and (null n) (= err sb-unix:eintr))) - ((or (null n) (zerop n)) - (error 'end-of-file :stream stream)) - (t (return n)))))))) - -(defun fd-stream-of (stream) - "Peel away SYNONYM-STREAM and TWO-WAY-STREAM wrappers until we reach - the underlying FD-STREAM. Signals a clear error if no FD-STREAM is found." - (etypecase stream - (sb-sys:fd-stream stream) - (synonym-stream (fd-stream-of (symbol-value (synonym-stream-symbol stream)))) - (two-way-stream (fd-stream-of (two-way-stream-input-stream stream))))) - -(defun %portable-read (stream buf start max-count) - "Fallback for streams with no raw fd. Reads one byte via READ-BYTE, - which blocks until it arrives and signals END-OF-FILE on - disconnect, same contract as %UNIX-READ. Never demands a full - buffer, so it can't reintroduce the old READ-SEQUENCE blocking bug; - one byte per call is fine since this path only ever serves - interactive typing." - (declare (ignore max-count)) - (setf (aref buf start) (read-byte stream)) - 1) - (defun nntp-read-article-to-disk (tmp-path) "Streams an article to disk." (let ((success nil)) @@ -2153,30 +2124,12 @@ disconnect still signals END-OF-FILE straight through, uncaught." (write-byte 13 out) (write-byte 10 out))))) -(defun nntp-read-article-old () - ;; Returns a vector of bytes: the article, CRLF between lines, up to - ;; (excluding) the "." terminator. VECTOR-PUSH-EXTEND grows the - ;; buffer in amortized O(1) per push, so total cost is O(size of the - ;; article) rather than O([size of the article]^2). - (let ((buf (make-array 8192 - :element-type '(unsigned-byte 8) - :adjustable t - :fill-pointer 0))) - (loop - (let ((ls (nntp-read-line))) - ;(stderr "nntp-read-line: [~A]" ls) - (when (eq ls :eof) (error 'end-of-file :stream *standard-input*)) - (when (end-of-article? ls) (return buf)) - (map nil (lambda (b) (vector-push-extend b buf)) ls) - (vector-push-extend 13 buf) - (vector-push-extend 10 buf))))) - (defun end-of-article? (ls) ;; A line is the NNTP terminator only if it's exactly the single byte ;; 46 (#\.). LENGTH/ELT instead of EQUAL-against-a-list, since ;; NNTP-READ-LINE hands back a vector. (and ls (not (eq ls :eof)) (= (length ls) 1) (= (elt ls 0) 46))) -@ %def nntp-read-article +@ %def nntp-read-line-buffered nntp-read-article-to-disk Now let's move to the complicated side of life. This is the very heart of \Lp. Our data structure of interest here is a buffer with two @@ -2344,9 +2297,9 @@ SLIME---and keeps the framing logic completely shared. "Peel away SYNONYM-STREAM and TWO-WAY-STREAM wrappers until we reach the underlying FD-STREAM. Signals a clear error if no FD-STREAM is found." (etypecase stream - (sb-sys:fd-stream stream) - (synonym-stream (fd-stream-of (symbol-value (synonym-stream-symbol stream)))) - (two-way-stream (fd-stream-of (two-way-stream-input-stream stream))))) + (sb-sys:fd-stream stream) + (synonym-stream (fd-stream-of (symbol-value (synonym-stream-symbol stream)))) + (two-way-stream (fd-stream-of (two-way-stream-input-stream stream))))) @ %def nntp-read-line-buffered <>= @@ -2357,43 +2310,12 @@ SLIME---and keeps the framing logic completely shared. (mapcar #'data->bytes (coerce v 'list))) (defun data->bytes (d) - (cond ((null d) nil) - ((integerp d) (list d)) - ((stringp d) (string->bytes d)) - ((consp d) (list->bytes d)) - ((vectorp d) (vector->bytes d)) - (t (error (format nil "type ~a is not supported" (type-of d)))))) - -(defun send-chunk! (chunk s) - "Writes chunks sequentially to the stream." - (cond ((stringp chunk) - (my-write (string->bytes chunk) s)) - ((vectorp chunk) - (my-write chunk s)) - ((listp chunk) - (dolist (c chunk) - (send-chunk! c s))) - ((integerp chunk) - (write-byte chunk s)) - ((file-stream-payload-p chunk) - (stream-file-to-socket chunk s)))) - -(defun stream-file-to-socket (payload out-stream) - "Opens the file, seeks to the start of the body, and streams to the socket - while applying on-the-fly NNTP dot-stuffing." - (with-open-file (in (file-stream-payload-path payload) - :element-type '(unsigned-byte 8)) - (file-position in (file-stream-payload-start-pos payload)) - (let ((buf (make-array 8192 :element-type '(unsigned-byte 8))) - (at-line-start t)) ; The body implicitly starts at the beginning of a line - (loop for n = (read-sequence buf in) - while (plusp n) - do (loop for i from 0 below n - for byte = (aref buf i) - do (when (and at-line-start (= byte 46)) ; 46 is '.' - (write-byte 46 out-stream)) - (write-byte byte out-stream) - (setf at-line-start (= byte 10))))))) ; 10 is LF (\n) + (etypecase d + (null nil) + (integer (list d)) + (string (string->bytes d)) + (cons (list->bytes d)) + (vector (vector->bytes d)))) (defun add-crlf-between (ls-of-ls) ;; Add \r\n to each ``line''. Returns List-of Byte. @@ -2443,7 +2365,7 @@ unclear right now what the wise measure is, so we'll keep on moving. "Convenience wrapper: parse the in-memory article and check headers." (catch 'article-syntax-error (conforms-headers? - (article-headers (parse-article bs))))) + (article-head (parse-article bs))))) (defun conforms-headers? (headers-str) "HEADERS-STR is the raw header block (without the body). @@ -2452,7 +2374,7 @@ unclear right now what the wise measure is, so we'll keep on moving. (let ((headers (parse-headers headers-str))) (let ((result (dolist (h (headers-required-from-clients)) (when (not (lookup h headers)) - (return (format nil "missing the /~a/ header" h)))))) + (return (fmt "missing the /~a/ header" h)))))) (cond ((stringp result) (values nil result)) (t @@ -2463,7 +2385,7 @@ unclear right now what the wise measure is, so we'll keep on moving. (not (group? g))) (push g ngs-dont-exist))) (if (not (zerop (length ngs-dont-exist))) - (values nil (format nil "the ~a ~a just ~a 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"))) @@ -2504,21 +2426,21 @@ all or it has been discussed with the community beforehand. (group-name-conforms? g) (if (not okay?) (make-response :code 580 :request r - :data (format nil "group name does not conform: ~a" reason)) + :data (fmt "group name does not conform: ~a" reason)) (progn (multiple-value-bind (path created?) (in-groups (ensure-directories-exist (concatenate 'string g "/"))) (declare (ignore created?)) (if (not path) (make-response :code 581 :request r - :data (format nil "could not create group ~a" + :data (fmt "could not create group ~a" (if (group? g) "because it already exists" "but we don't know why---sorry!"))) (progn (notify-group-created g) (make-response :code 280 :request r - :data (format nil "group ~a created" g))))))))))) + :data (fmt "group ~a created" g))))))))))) (defun group-name-conforms? (g) (conforms-to? g "<
>")) @@ -2577,7 +2499,7 @@ invitations {\em et cetera} are published there. (defun post-notification (&key subject body) (in-groups (ensure-directories-exist "local.control.news/")) (when (group? "local.control.news") - (let ((tmp (format nil "notify-~a.tmp" (random-string 10))) + (let ((tmp (fmt "notify-~a.tmp" (random-string 10))) (mid (suggest-message-id))) (unwind-protect (progn @@ -2589,11 +2511,11 @@ invitations {\em et cetera} are published there. (flet ((wline (s) (write-sequence (map 'vector #'char-code s) out) (write-byte 13 out) (write-byte 10 out))) - (wline (format nil "From: Loop")) - (wline (format nil "Subject: ~a" subject)) - (wline (format nil "Newsgroups: local.control.news")) - (wline (format nil "Message-ID: ~a" mid)) - (wline (format nil "Date: ~a" (get-date))) + (wline (fmt "From: Loop")) + (wline (fmt "Subject: ~a" subject)) + (wline (fmt "Newsgroups: local.control.news")) + (wline (fmt "Message-ID: ~a" mid)) + (wline (fmt "Date: ~a" (get-date))) (write-byte 13 out) (write-byte 10 out) (write-sequence (map 'vector #'char-code body) out) (write-byte 13 out) (write-byte 10 out))) @@ -3027,7 +2949,7 @@ any more. (,r-var ,r)) (if (not (group? ,g-var)) (make-response :code 411 :request ,r-var - :data (format nil "no such group ``~a''" ,g-var)) + :data (fmt "no such group ``~a''" ,g-var)) (progn ,@body))))) (defmacro with-n-args (n r &rest body) @@ -3116,7 +3038,7 @@ means 2 bytes. So our conversion is just removing the first byte. (make-response :code (or code 400) :data msg :request r)) (defun integer->string (n) - (format nil "~a" n)) + (fmt "~a" n)) (defun mkstr (&rest args) ;; a utility (with-output-to-string (s) @@ -3129,7 +3051,7 @@ means 2 bytes. So our conversion is just removing the first byte. (vector 13 10)) (defun crlf-string () - (format nil "~c~c" #\return #\linefeed)) + (fmt "~c~c" #\return #\linefeed)) (defun flatten (obj) (do* ((result (list obj)) @@ -3312,6 +3234,7 @@ something to think about. <> <> <> +<> <> <> <>