root/loop
1
0
Fork 0
Code Issues Pull requests Activity

Goes low-level for fast reading.

Browse source
This commit is contained in:
Circling Skies 2026-07-15 19:33:38 -03:00
parent 94d2e78447
commit 47e29139de
2 changed files with 527 additions and 92 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

228
loop.lisp
View file

@ -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
(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*))))
(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.")))))
(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 ()
(handler-case
(loop
(let* ((bs (nntp-read-line))
(ln (bytes->string (ucs-2->ascii bs))))
(ln (bytes->string bs)))
(let ((r (send-response! (dispatch-line ln))))
(when (response-quit? r)
(return))))))
(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))))

365
loop.nw
View file

@ -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.
<<Main loop.lisp>>=
(defun main-loop ()
(handler-case
(loop
(let* ((bs (nntp-read-line))
(ln (bytes->string (ucs-2->ascii bs))))
(ln (bytes->string bs)))
(let ((r (send-response! (dispatch-line ln))))
(when (response-quit? r)
(return))))))
(return)))))
(end-of-file (c)
(declare (ignore c))
(stderr "EOF~%"))
(error (e)
(stderr "fatal: ~A" e))))
@ %def main-loop
<<Main loop.lisp>>=
(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 "<<Welcome message>>")))
@ %def main main-loop
@ %def main
\noindent It's always useful to know which version exactly we're
dealing with:
@ -1837,6 +1846,7 @@ 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))))))))
@
@ -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.
<<Command post.lisp>>=
(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.
<<Global variable to hold the connections spoken lines.lisp>>=
(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.
<<Command post.lisp>>=
(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.
<<Command post.lisp>>=
(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,14 +2299,14 @@ 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.
<<Does an article conform?.lisp>>=
(defun conforms? (bs)
@ -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.
<<Command repl.lisp>>=
@ -2431,11 +2701,9 @@ We now implement some of the \hyperref[principles]{principles} exposed
earlier on page~\pageref{principles}. The program
@<<cron-remove-inactive-users.lisp@>> 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.
<<cron-remove-inactive-users.lisp>>=
<<Quicklisp loading preamble.lisp>>
@ -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.
<<How to remove inactive users.lisp>>=
(defun remove-account! (username)
@ -2961,6 +3225,7 @@ something to think about.
<<Representation of articles.lisp>>
<<Definition of maximum allowed inactive periods.lisp>>
<<Global variable that decides whether to enable the NNTP REPL.lisp>>
<<Global variable to hold the connections spoken lines.lisp>>
@
On which packages do we depend?