diff --git a/loop.lisp b/loop.lisp index 45dbaee..3820cd5 100644 --- a/loop.lisp +++ b/loop.lisp @@ -31,6 +31,15 @@ (defparameter *months-inactive-allowed* 3) (defparameter *months-never-logged-in* 1) (defparameter *enable-nntp-repl* t) +(defstruct nntp-stream-buffer + (data (make-array 8192 :element-type '(unsigned-byte 8))) + (head 0 :type fixnum) + (tail 0 :type fixnum)) + +(defparameter *network-buffer* (make-nntp-stream-buffer)) + +(defun nntp-read-line (&optional (s *standard-input*)) + (nntp-read-line-buffered s *network-buffer*)) (defun table-of-commands () `(("GROUP" ,#'cmd-group "sets the current group") @@ -876,9 +885,21 @@ (content-type (get-header "content-type" headers))) (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 (values t nil))))))) + ;((not (text/plain? content-type)) + ; (values nil (format nil "content-type must be plain/text, but it's ~a" content-type))) + (t + (let ((ngs (newsgroups-header->list (get-header "newsgroups" headers))) + (ngs-dont-exist nil)) + (dolist (g ngs) + (when (or (not (group-name-conforms? g)) + (not (group? g))) + (push g ngs-dont-exist))) + (if (not (zerop (length ngs-dont-exist))) + (values nil (format nil "the ~a ~a just ~a exist" + (word-plural (length ngs-dont-exist) "newsgroup") + (str:join ", " (sort ngs-dont-exist #'string<)) + (word-plural (length ngs-dont-exist) "doesn't"))) + (values t nil))))))))) (defun text/plain? (header-s) ;; I say T when S begins with "text/plain" or when S is "". @@ -953,29 +974,18 @@ :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)))))))) (defun post (bs) (let ((ngs (newsgroups-header->list (get-header "newsgroups" (parse-headers - (article-headers - (parse-article bs)))))) - (ngs-dont-exist)) - (dolist (g ngs) - (if (or (not (group-name-conforms? g)) - (not (group? g))) - (push g ngs-dont-exist))) - (if (zerop (length ngs-dont-exist)) - (progn - (dolist (ng ngs) - (let ((a (ensure-date (ensure-mid bs)))) - (save-article-insist ng (get-next-article-id ng) a (extract-mid a)) - (update-last-post-date! (client-username *client*)))) - (values 240 (data "Thank you! Your article has been saved."))) - (values 400 (data "Sorry. We did not post your article to any newsgroup because " - "the " (word-plural (length ngs-dont-exist) "newsgroup") " " - (str:join ", " (sort ngs-dont-exist #'string<)) - " just " (word-plural (length ngs-dont-exist) "doesn't") " exist."))))) + (article-headers + (parse-article bs))))))) + (dolist (ng ngs) + (let ((a (ensure-date (ensure-mid bs)))) + (save-article-insist ng (get-next-article-id ng) a (extract-mid a)))) + (values 240 (data "Thank you! Your article has been saved.")))) (defun newsgroups-header->list (s) (mapcar #'(lambda (n) (str:trim (string-downcase n))) (str:split "," s))) @@ -1021,19 +1031,172 @@ (defun nntp-read-article (&optional acc) ;; Returns List-of Byte. - (let* ((ls (ucs-2->ascii (nntp-read-line)))) - (cond ;; 46 == (byte #\.) - ((equal (list 46) ls) (flatten (add-crlf-between acc))) - (t (nntp-read-article (append acc (list ls))))))) + (let* ((ls (nntp-read-line))) + (stderr "I read: [~A]" ls) + (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)))))))) -(defun nntp-read-line (&optional (s *standard-input*) acc) - ;; Returns List-of Byte. +(defun nntp-read-line-buffered (stream buffer) + (if (interactive-stream-p stream) + (get-interactive-line stream) + (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 %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 %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))) ; signal interrupted syscall – retry + ((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 + +(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 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 + +(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))))) + +(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))))) - (stderr "<<< ~a~%" (bytes->string (ucs-2->ascii bs))) bs)) - (t (nntp-read-line s (cons x acc)))))) + (t (nntp-read-line-slow s (cons x acc)))))) (defun list->bytes (ls) (mapcar #'data->bytes ls)) @@ -1393,7 +1556,8 @@ (new-passwd (or given-passwd random-passwd))) (if (not (get-account username)) (println "No such account ``~a''." username) - (multiple-value-bind (okay? problem) (change-passwd! username new-passwd) (if okay? + (multiple-value-bind (okay? problem) (change-passwd! username new-passwd) + (if okay? (println "Okay, account ~a now has password ``~a''." username new-passwd) (println "Sorry, could not change password: ~a." problem)))))) @@ -1445,12 +1609,18 @@ :handler #'cli/main-with-handlers)) (defun main-loop () - (loop - (let* ((bs (nntp-read-line)) - (ln (bytes->string (ucs-2->ascii bs)))) - (let ((r (send-response! (dispatch-line ln)))) - (when (response-quit? r) - (return)))))) + (handler-case + (loop + (let* ((bs (nntp-read-line)) + (ln (bytes->string bs))) + (let ((r (send-response! (dispatch-line ln)))) + (when (response-quit? r) + (return))))) + (end-of-file (c) + (declare (ignore c)) + (stderr "EOF~%")) + (error (e) + (stderr "fatal: ~A" e)))) (defun request-quit? (r) (and r (string= 'quit (request-verb r)))) diff --git a/loop.nw b/loop.nw index 1af2908..7cf5eb8 100644 --- a/loop.nw +++ b/loop.nw @@ -1,5 +1,6 @@ % -*- mode: poly-noweb; -*- \documentclass[a4paper,11pt]{article} + \usepackage[text={6.75in,10in},centering]{geometry} \usepackage{graphicx} @@ -608,13 +609,21 @@ itself---so we can cascade actions based on a user's request. <
>= (defun main-loop () - (loop - (let* ((bs (nntp-read-line)) - (ln (bytes->string (ucs-2->ascii bs)))) - (let ((r (send-response! (dispatch-line ln)))) - (when (response-quit? r) - (return)))))) + (handler-case + (loop + (let* ((bs (nntp-read-line)) + (ln (bytes->string bs))) + (let ((r (send-response! (dispatch-line ln)))) + (when (response-quit? r) + (return))))) + (end-of-file (c) + (declare (ignore c)) + (stderr "EOF~%")) + (error (e) + (stderr "fatal: ~A" e)))) +@ %def main-loop +<
>= (defun request-quit? (r) (and r (string= 'quit (request-verb r)))) (defun response-quit? (r) (and r (request-quit? (response-request r)))) @@ -632,7 +641,7 @@ itself---so we can cascade actions based on a user's request. (make-response :code 200 :data "<>"))) -@ %def main main-loop +@ %def main \noindent It's always useful to know which version exactly we're dealing with: @@ -1837,13 +1846,14 @@ of trying to stop them. :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)))))))) @ It's time to write the action of posting. One thing to keep in mind is cross-posting. First, notice that we're---so far---duplicating articles on the file system. (We will undo that once we reimplement -our index. More to follow.) +our index. More to follow.) <>= (defun post (bs) @@ -1853,8 +1863,7 @@ our index. More to follow.) (parse-article bs))))))) (dolist (ng ngs) (let ((a (ensure-date (ensure-mid bs)))) - (save-article-insist ng (get-next-article-id ng) a (extract-mid a)) - (update-last-post-date! (client-username *client*)))) + (save-article-insist ng (get-next-article-id ng) a (extract-mid a)))) (values 240 (data "Thank you! Your article has been saved.")))) (defun newsgroups-header->list (s) @@ -1944,42 +1953,303 @@ allocated. Notice that the argument [[name]] is an integer, so @ %def save-article-insist get-next-article-id {\bf How to read lines in the NNTP protocol?} We've implemented the -most trivial strategy possible. It's also the slowest. What I think -we need to do here is to use [[vector-push-extend]]. But this is to -be done in [[nntp-read-line]]. I hope to be able to get a faster -procedure in [[nntp-read-line]] and keep [[nntp-read-article]] as it -is. This is important to speed up posting. For instance, if we allow -attachments (which we don't), the performance penalty is clearly -noticeable. %%TODO +most trivial strategy possible in [[nntp-read-line-slow]]. It's also +the slowest, so we don't use it anymore but we keep it here to tell +the story. For speed reasons, life is complicated here, so let's take +things one at a time. First of all, how do we read an article? Well, +we read a line and---if that line happens to be a lonely dot, then +that's the end of the article, so we just return a list of +lines. Otherwise, we continue by attaching the new line to the end of +our accumulated list of lines. <>= (defun nntp-read-article (&optional acc) ;; Returns List-of Byte. - (let* ((ls (ucs-2->ascii (nntp-read-line)))) - (cond ;; 46 == (byte #\.) - ((equal (list 46) ls) (flatten (add-crlf-between acc))) - (t (nntp-read-article (append acc (list ls))))))) + (let* ((ls (nntp-read-line))) + (stderr "I read: [~A]" ls) + (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 -The NNTP protocol establishes that line termination is done with -\verb|\r\n|, but it's useful to support UNIX line terminations, too, -because we are using the command-line and interacting directly with -the server using tools that will not always send \verb|\r\n| as line -termination. For example, when someone is typing directly from the -keyboard and insert an empty line, we need the {\tt (and acc ...)} -because sometimes the list [[acc]] comes out empty, but an empty line -never comes from the NNTP protocol because there's is always a {\tt - CR} before {\tt LF}. +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 +pointers into it, {\tt head} and {\tt tail}. The head just points to +a place in the buffer where data yet to be consumed begins and {\tt + tail} points to where it ends. All data coming through the network +(or coming locally from someone's keyboard on standard input) is +stored in this buffer. + +<>= +(defstruct nntp-stream-buffer + (data (make-array 8192 :element-type '(unsigned-byte 8))) + (head 0 :type fixnum) + (tail 0 :type fixnum)) + +(defparameter *network-buffer* (make-nntp-stream-buffer)) + +(defun nntp-read-line (&optional (s *standard-input*)) + (nntp-read-line-buffered s *network-buffer*)) +@ %def *network-buffer* + +Why do we need a fast procedure here? Because io is the slowest thing +in computers. For instance, if we allow attachments in posts (which +we don't), the performance penalty is clearly noticeable. + +The procedure [[nntp-read-line-buffered]] is pretty much as fast as we +can get, but it's considerably more complicated. One part of the +complication is that, because information comes from the network, we +could get partial lines. I must also say that I was not able to get a +general solution for both network and keyboard connections, which is +why I'm using [[interactive-stream-p]] to detect whether I'm in a +terminal-interactive session. The NNTP protocol establishes that line +termination is done with \verb|\r\n|, but it's useful to support UNIX +line terminations, too, because we are using the command-line and +interacting directly with the server using tools that will not always +send \verb|\r\n| as line termination. + +When interactively, I do the slow thing---I read byte by byte and +collect it up into the line-bytes array, which is the business of +[[get-interactive-line]]. When not interactively, we'll have to face +the complications. + +We have two important tools to tame the complication. The first is +[[find-lf]], the procedure responsible to find the position of the +linefeed in the network buffer. Now [[extract-line]] returns a line +stored in the buffer and [[refill-and-extract-line]] gets more data +from the network and stores it into the buffer, returning a line after +refilling. We need to understand their dance in order to be +comfortable with the main part of io of \Lp. + +How to read the procedure [[nntp-read-line-buffered]]? The procedure +is an entire program and it has a library. The main program is at the +bottom. We begin by trying to find a linefeed in the buffer. If +there is one, it's because there's an entire line to be extracted and +consumed. If there isn't a newline, it's either because the buffer is +empty or because there's only a partial line in the buffer. A partial +line must be joined with its remaining which is still to arrive from +the network, so we refill the buffer. Initially, of course, the +buffer is completely empty, so the very first thing that happens is we +invoke refill to extract a first line. + +What's the work of refilling it? If the buffer is empty, then we just +need to read more data and write it out onto the buffer. The writing +itself is actually done by [[read-sequence]], so our job is just to do +the bookkeeping. The very first thing to be done is to make sure that +we have enough space for the next [[read-sequence]]. If someone sends +a very long line, then we might run out of space. We detect that by +checking whether [[remaining]] is at the very end of the the buffer. +This means we have no more space for even a single byte, so we throw +an error and [[main-loop]] decides what to do. + +Another important thing to understand is that a partial line might be +stored in the buffer after one or a few complete lines. To view this +situation properly, we should explain how [[extract-line]] +works. Suppose the buffer has been filled with 2 lines and a third +partial line. (Is this realistic? Certainly: anything could arrive +from the network.) Once [[extract-line]] is invoked, the first line +is returned and the head of the buffer is moved past the first line. +Then the subsequent line is returned and the head is moved again to +the beginning of the third, partial line. Because the line is now +partial, more data will have to be read from the network. That's when +the check [[(> remaining 0)]] will evaluate to true. Before we write +more data into the buffer, we will move that partial line to the +beginning of the buffer---that's the job of [[replace]]. With that in +mind, we can close this chapter and open a new mental context having +invoked [[read-sequence]] and read more bytes or having found eof. + +If an eof has been detected and we did have a partial line waiting to +be completed, we will return that partial line to the caller and it's +up to the caller to decide what to do with it. Probably, the best +thing to do is to log the fact and close the connection. A partial +line really indicates a client in trouble---in fact, the client itself +has already closed the connection, since we read eof. Nevertheless, +it is our job to deliver everything we have to the caller, so we must +do our duty here. + +If new bytes arrived, then we just search for a linefeed and extract +the new line. We should inquiry here why we're trying to extract a +line in two places: after refilling the buffer and in the main +program. I think it's just trivial to do our jobs that way. How +would we do it otherwise? We would have to redesign the dynamics +between these procedures. + +As you can see, it's complicated. I do feel uneasy that I am not +somehow using a solution made in some advanced library. This could be +the case that we know so little about what's out there that we might +need to dive into the work and do it ourselves. I think understanding +libraries is a lot of work, so if we are reinventing the wheel here, I +think it is not bad for our education considering we want complete +understanding of how our software works. This is a deep discussion +about how a programmer should conduct himself in his life, considering +productivity and education. <>= -(defun nntp-read-line (&optional (s *standard-input*) acc) - ;; Returns List-of Byte. +(defun nntp-read-line-buffered (stream buffer) + (if (interactive-stream-p stream) + (get-interactive-line stream) + (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 %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 %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))) ; signal interrupted syscall – retry + ((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 + +(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 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 +most complicated task of \Lp. All the rest is a total breeze. + +<>= +(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))))) + +(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))))) - (stderr "<<< ~a~%" (bytes->string (ucs-2->ascii bs))) bs)) - (t (nntp-read-line s (cons x acc)))))) + (t (nntp-read-line-slow s (cons x acc)))))) (defun list->bytes (ls) (mapcar #'data->bytes ls)) @@ -2029,17 +2299,17 @@ So the message here is that if an article is vetted by [[conforms?]], then it can be saved. Any problem with the article must be reported by [[conforms?]]. -XXX: heads up. We have a [[catch]] here and a [[throw]] in -[[parse-headers]]. We also have a [[return]] here. It's getting hard -to read this procedure because it's not easy to know that a procedure -has to return a certain value to match the expectation of another -procedure. I don't remember what [[catch]] does. I need to review -this and then add the explanation for myself. If I don't remember how -this works, other beginners won't know it either. It's unclear right -now what the wise measure is, so we'll keep on moving. +Something to think about is that we have a [[catch]] here and a +[[throw]] in [[parse-headers]]. We also have a [[return]] here. It's +getting hard to read this procedure because it's not easy to know that +a procedure has to return a certain value to match the expectation of +another procedure. I don't remember what [[catch]] does. I need to +review this and then add the explanation for myself. If I don't +remember how this works, other beginners won't know it either. It's +unclear right now what the wise measure is, so we'll keep on moving. <>= -(defun confor ms? (bs) +(defun conforms? (bs) (catch 'article-syntax-error ;; parse-headers might throw (let ((headers (parse-headers (article-headers (parse-article bs))))) (let ((result (dolist (h (headers-required-from-clients)) @@ -2048,8 +2318,8 @@ now what the wise measure is, so we'll keep on moving. (content-type (get-header "content-type" headers))) (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))) + ;((not (text/plain? content-type)) + ; (values nil (format nil "content-type must be plain/text, but it's ~a" content-type))) (t (let ((ngs (newsgroups-header->list (get-header "newsgroups" headers))) (ngs-dont-exist nil)) @@ -2121,7 +2391,7 @@ all or it has been discussed with the community beforehand. \subsection{{\tt REPL}} -\lp\ is totally {\em hackable}. Users can say {\tt repl} to have +\lp\ is {\em totally} hackable. Users can say {\tt repl} to have complete control over their \lxxp\ process. <>= @@ -2431,11 +2701,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 (to be deleted later) or deletes them {\em for +either locks them or deletes them {\em for good}. If you want to keep accounts forever, just don't run the -program. XXX: our idea is to also delete {\em for good} all accounts -that are locked (by the same period of time), but we have not yet done -that. +program. I've decided to never delete accounts that are inactive. <>= <> @@ -2480,12 +2748,8 @@ removed) from anyone's list of friends. So, this involves scanning the entire list of accounts. Also, notice that delete ``may modify {\em sequence}''. More important is to understand that we really must {\tt setf} the return, otherwise we might find the deletion did not -take effect---for example, when deleting the first element of a list. -XXX: this deserves a better explanation, but if you know how linked -lists are implemented in C, say, then you're likely well aware of how -it works. Months later I can't remember what the issue really is, -though I remember what it is. Let's write a better explanation here as -soon as we have enough energy to trace all the problem. +take effect---for example, when deleting the first element of a +list. <>= (defun remove-account! (username) @@ -2961,6 +3225,7 @@ something to think about. <> <> <> +<> @ On which packages do we depend?