diff --git a/loop.nw b/loop.nw index ab5789b..4ed8ebf 100644 --- a/loop.nw +++ b/loop.nw @@ -544,13 +544,6 @@ mark such responses with [[multi-line]]. :data (list message (crlf) (response-data r)) :multi-line (response-multi-line r) :request (response-request r))) - -(defun prepend-response-with-old (message r) - (make-response - :code (response-code r) - :data (data 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. @@ -579,18 +572,6 @@ Here's how to send a [[response]] to a client. (send-chunk! (crlf) *standard-output*)) (force-output) r) - -(defun send-response-old! (r) - (let ((bs (data (integer->string (response-code r)) " " - (append-crlf-if-needed (response-data r))))) - (my-write bs *standard-output*) - (stderr ">>> ~a" (bytes->string (ucs-2->ascii bs)))) - (when (response-multi-line r) - (let ((bs (data "." (crlf)))) - (my-write bs *standard-output*) - (stderr ">>> ~a" (bytes->string (ucs-2->ascii bs))))) - (force-output) - r) @ %def send-response! {\bf XXX: dead paragraph}. (We're not running Windows anymore and @@ -643,7 +624,7 @@ itself---so we can cascade actions based on a user's request. (return))))) (end-of-file (c) (declare (ignore c)) - (stderr "EOF~%")) + (stderr "a client disconnected with EOF~%")) (error (e) (stderr "fatal: ~A" e)))) @ %def main-loop @@ -917,10 +898,6 @@ time. %% TODO :headers (map 'string #'code-char v) :body (make-array 0 :element-type (array-element-type v)))))) -(defun parse-article-old (v) - (let ((parts (split-vector (vector 13 10 13 10) v nil :limit 2))) - (make-article :headers (map 'string #'code-char (car parts)) :body (cadr parts)))) - (defun hs-space-collapsed (hs) (cl-ppcre:regex-replace-all (format nil "~a[ ~a]+" (crlf-string) #\tab) hs " ")) @@ -950,9 +927,6 @@ We now write some procedures that we use when we're build the {\em overview} of the command \verb|XOVER|. <>= -(defun get-header-from-article (h a) - (get-header h (parse-headers (article-headers (parse-article a))))) - (defun get-header (key hs) (let ((pair (assoc key hs :test #'string=))) (if pair (cdr pair) ""))) @@ -981,9 +955,39 @@ the article viewer's---the NNTP client's, that is---responsibility of interpreting such bytes. That's why we call [[read-sequence]] here. <>= +(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)))))))))))) + +(defstruct file-stream-payload + (path "" :type string) + (start-pos 0 :type integer)) + (defun fetch-article (g i) (in-groups - (read-file-raw (format nil "~a/~a" g i)))) + (read-headers-raw (format nil "~a/~a" g i)))) (defun read-file-raw (path) (with-open-file @@ -995,9 +999,6 @@ interpreting such bytes. That's why we call [[read-sequence]] here. (a (make-array size))) (read-sequence a in) a)))) - -(defun fetch-body (g i) - (article-body (parse-article (fetch-article g i)))) @ %def fetch-article The procedures [[extract-mid]] and [[lookup]] also belong belong in @@ -1594,11 +1595,11 @@ Section~\ref{sec:index} for the implementation of the index. (typical-cmd-head-body-article r #'article-response)) (defun article-response (r g i) - (typical-cmd-response 220 r g i #'(lambda (a) a))) + (typical-cmd-response 220 r g i :article)) (defun head-response (r g i) - (typical-cmd-response 221 r g i #'(lambda (a) (article-headers (parse-article a))))) + (typical-cmd-response 221 r g i :head)) (defun body-response (r g i) - (typical-cmd-response 222 r g i #'(lambda (a) (article-body (parse-article a))))) + (typical-cmd-response 222 r g i :body)) @ In processing such commands, we need to verify the existence of files @@ -1621,29 +1622,35 @@ enough code to treat any future case we might want to add and we're not ignoring any errors at all. <>= -(defun typical-cmd-response (code r g i get-data) - (handler-case - (let ((a (fetch-article g i))) - (cond ((null a) - (make-response - :code 400 :request r - :data (format nil "article ~a/~a does not exist" g i))) - (t - (prepend-response-with - (format nil "~a ~a" i (extract-mid a)) - (make-response :multi-line 'yes :code code - :request r :data (funcall get-data a)))))) +(defun typical-cmd-response (code r g i requested-part) + (handler-case + (let* ((path (format nil "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)) + (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)) + (:body (make-file-stream-payload :path path :start-pos header-length)) + (:article (list (article-headers a) + (crlf) + (make-file-stream-payload :path path :start-pos header-length)))))) + + (prepend-response-with (format nil "~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))) (stderr msg) - (make-response - :code 400 :request r :data 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))) (stderr msg) - (make-response - :code 400 :request r - :data msg))))) + (make-response :code 400 :request r :data msg))))) @ %def typical-cmd-response The command \verb|NEXT| has a slight different semantics. @@ -1818,15 +1825,6 @@ now is not the time for fixing this. (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 unparse-article-old (parsed) - (data - (let ((ls)) - (dolist (h (parse-headers (article-headers parsed))) - (setq ls (cons (data (str:capitalize (car h)) ": " (cdr h) (crlf)) ls))) - (nreverse ls)) - (crlf) - (article-body parsed))) @ %def unparse-article If an article being posted has no \verb|message-id| or \verb|date|, @@ -1906,13 +1904,13 @@ our index. More to follow.) <>= (defun post (bs) - (let ((ngs (newsgroups-header->list - (get-header "newsgroups" (parse-headers - (article-headers - (parse-article 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))) (dolist (ng ngs) - (let ((a (ensure-date (ensure-mid bs)))) - (save-article-insist ng (get-next-article-id ng) a (extract-mid a)))) + (save-article-insist ng (get-next-article-id ng) a mid)) (values 240 (data "Thank you! Your article has been saved.")))) (defun newsgroups-header->list (s) @@ -2015,8 +2013,8 @@ our accumulated list of lines. (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(article - ;; size) rather than O(article size^2). + ;; 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 @@ -2035,18 +2033,6 @@ our accumulated list of lines. ;; 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))) - -(defun nntp-read-article-slow (&optional acc) - ;; Returns List-of Byte. - (let* ((ls (nntp-read-line))) - (cond ;; a single period "." on a line marks the end of the - ;; article. That is, 46 == (byte #\.) - ((and (= 1 (length ls)) - (= 46 (aref ls 0))) - (flatten (add-crlf-between acc))) - (t - (nntp-read-article - (append acc (list (coerce ls 'list)))))))) @ %def nntp-read-article Now let's move to the complicated side of life. This is the very @@ -2171,17 +2157,17 @@ productivity and education. ((find-lf (start end) (position 10 data :start start :end end)) (extract-line (lf-pos) - (let* ((start (nntp-stream-buffer-head buffer)) + (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))) + (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)) + (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]" @@ -2204,8 +2190,8 @@ productivity and education. (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 + (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 @@ -2213,14 +2199,12 @@ productivity and education. (refill-and-extract-line))))))) (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 @@ -2229,10 +2213,10 @@ productivity and education. (sb-sys:sap+ (sb-sys:vector-sap buf) start) max-count) (cond - ((and (null n) (= err sb-unix:eintr))) ; signal interrupted syscall – retry + ((and (null n) (= err sb-unix:eintr))) ((or (null n) (zerop n)) - (error 'end-of-file :stream stream)) ; error or clean EOF (client closed) - (t (return n)))))))) ; got at least one byte + (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 @@ -2241,60 +2225,6 @@ productivity and education. (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 nntp-read-line-buffered-old (stream buffer) - (if (interactive-stream-p stream) - (get-interactive-line stream) - (let ((data (nntp-stream-buffer-data buffer))) - (labels ((find-lf (start end) - (position 10 data :start start :end end)) - (extract-line (lf-pos) - (let* ((start (nntp-stream-buffer-head buffer)) - ;; if the previous byte is CR, strip it out - (end-line (if (and (> lf-pos start) (= (aref data (1- lf-pos)) 13)) - (1- lf-pos) - lf-pos)) - (line (subseq data start end-line))) - ;; move the pointer past the LF and return the 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))) - ;; first of all, if there's no more space, then - ;; simply give up the entire operation. It's up - ;; to the caller to decide what to do. - (when (= remaining (length data)) - (stderr "line too long in the network buffer: [~A]" - (subseq data head remaining)) - (error "no space left on the network buffer for the current line")) - ;; 1. shift remaining bytes to the beginning of the array - (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) - ;; 2. invoke read-sequence to fill the rest of the buffer - (let* ((new-tail-pos (read-sequence data stream :start remaining))) - (if (= new-tail-pos remaining) - ;; no new bytes arrived, so I presume eof has arrived - (if (> remaining 0) - (let ((line (subseq data 0 remaining))) - (setf (nntp-stream-buffer-tail buffer) 0) - line) - (error 'end-of-file :stream stream)) - (progn ;; new bytes arrived - (setf (nntp-stream-buffer-tail buffer) new-tail-pos) - - (let ((lf-pos (find-lf remaining new-tail-pos))) - (if lf-pos - (extract-line lf-pos) - (refill-and-extract-line))))))))) ; very long line - ;; --- main program --- - (let ((lf-pos (find-lf (nntp-stream-buffer-head buffer) (nntp-stream-buffer-tail buffer)))) - (if lf-pos - (extract-line lf-pos) ; quickly extract a line - (refill-and-extract-line))))))) ; get more data from the network @ %def nntp-read-line-buffered Phew! That was a lot! Take heart, though: you've just gone through the @@ -2316,13 +2246,6 @@ most complicated task of \Lp. All the rest is a total breeze. nil line-bytes))))) -(defun nntp-read-line-slow (&optional (s *standard-input*) acc) ;; Returns List-of Byte. - (let ((x (read-byte s))) - (cond ((or (null x) (= x 10)) - (let ((bs (and acc (nreverse (if (= (car acc) 13) (cdr acc) acc))))) - bs)) - (t (nntp-read-line-slow s (cons x acc)))))) - (defun list->bytes (ls) (mapcar #'data->bytes ls)) @@ -2347,7 +2270,26 @@ most complicated task of \Lp. All the rest is a total breeze. (dolist (c chunk) (send-chunk! c s))) ((integerp chunk) - (write-byte chunk s)))) + (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) (defun add-crlf-between (ls-of-ls) ;; Add \r\n to each ``line''. Returns List-of Byte. @@ -2718,18 +2660,6 @@ doesn't really support symbolic links. \section{Procedure to import the index from the file system} -%% get group: -%% (first (last (pathname-directory (car (in-groups (directory "**/*")))))) - -%% get article name: -%% (pathname-name (car (in-groups (directory "**/*")))) - -%% get all articles -%% LOOP> (in-groups (directory "**/*")) - -%% get the newsgroup header from the article -%% LOOP> (get-header-from-article "newsgroups" (fetch-article "comp.lang.lisp" "1")) - When we build the index from scratch, it's important to have a procedure capable of reading all articles in the file system and index them one by one. This is what we implement right here. For each news @@ -2785,9 +2715,9 @@ We now implement some of the \hyperref[principles]{principles} exposed earlier on page~\pageref{principles}. The program @<> would be run by {\tt cron} every day (at midnight, say). It checks all accounts that are inactive and -either locks them or deletes them {\em for - good}. If you want to keep accounts forever, just don't run the -program. I've decided to never delete accounts that are inactive. +either locks them. If you want to keep accounts forever, just don't +run the program. I've decided to never delete accounts that are +inactive, so I only lock them. <>= <> @@ -3148,27 +3078,15 @@ Newsgroups: local.test, bad.newsgroup A bad test from the biggest mouth of the south. ")) - -(define-test post-wrong-newsgroup - (multiple-value-bind (code msg) (post (string->bytes a-bad-post)) - (declare (ignore msg)) - (assert-true (equal code 400)))) - -(define-test post-okay - (read-accounts!) - (connect-index! "test.db") - (create-index!) - (setq *client* (make-client :username "ROOT" :auth? 'yes)) - (multiple-value-bind (code msg) (post (string->bytes a-post)) - (declare (ignore msg)) - (assert-true (equal code 240))) - (clsql:disconnect)) @ %def XXX: we got a problem with test [[post-okay]]. We're getting an execution error, but we can't see any error message. The posting is taking place---here in the REPL at least. +XXX: I removed the tests. We're making so many deep changes that we +need to rethink the tests. + \section{How to produce the binary executable} Just say {\tt make loop} to your shell.