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

Streams POSTed articles to disk, allowing huge articles to be posted.

Browse source 
This commit freezes a point in which we know our implementation is
tested and we're confident in the algorithms.  But we know there are
minor bugs easily fixable.  We proceed now to a major rewrite of
everything to better accommodate the new strategy.  In the process, we
might break things, which is why we're freezing this safe point.
This commit is contained in:
Circling Skies 2026-07-31 13:11:06 -03:00
parent 48dd285cd0
commit efb1410785
2 changed files with 322 additions and 290 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Anyfile
View file

@ -7,7 +7,7 @@ all: loop.exe loop.lisp loop.asd scripts/build-exe.lisp \
scripts/build-index-from-fs.lisp \
scripts/cron-remove-inactive-users.lisp \
scripts/migrate-add-creation-date.lisp \
version.lisp
version.lisp TAGS
version.lisp: loop.lisp
echo "(in-package :loop)" > version.lisp

574
loop.nw
View file

@ -76,20 +76,32 @@ the list of destinataries. So long as everyone replies to everyone,
John too will get all the messages. If anyone violates this rule of
replying to everyone involved, the loop is broken.
%% \begin{figure}[!htb]
%% \centering \includegraphics[width=0.8\linewidth]{images/gnus-summary.png}
%% \caption{Gnus, a news reader embedded in the GNU EMACS text editor.}
%% \label{fg:gnus}
%% \end{figure}
\begin{figure}[!htb]
\centering \includegraphics[width=0.8\linewidth]{images/gnus-summary.png}
\centering \includegraphics[width=0.8\linewidth]{images/gnus-article.png}
\caption{Gnus, a news reader embedded in the GNU EMACS text editor.}
\label{fg:gnus}
\end{figure}
\begin{figure}[!htb]
\centering \includegraphics[width=0.8\linewidth]{images/tbird-summary.png}
\caption{Thunderbird, a news reader produced by the Mozilla Foundation.}
\label{fg:bird}
\end{figure}
%% \begin{figure}[!htb]
%% \centering \includegraphics[width=0.8\linewidth]{images/tbird-summary.png}
%% \caption{Thunderbird, a news reader produced by the Mozilla Foundation.}
%% \label{fg:bird}
%% \end{figure}
%% \begin{figure}[!htb]
%% \centering \includegraphics[width=0.8\linewidth]{images/sylpheed-summary.png}
%% \caption{Sylpheed, a news reader produced by Hiroyuki Yamamoto.}
%% \label{fg:sylpheed}
%% \end{figure}
\begin{figure}[!htb]
\centering \includegraphics[width=0.8\linewidth]{images/sylpheed-summary.png}
\centering \includegraphics[width=0.8\linewidth]{images/sylpheed-reading.png}
\caption{Sylpheed, a news reader produced by Hiroyuki Yamamoto.}
\label{fg:sylpheed}
\end{figure}
@ -350,10 +362,10 @@ connections, we use what is called a ``TCP superserver'' or ``TCP
wrappers'' or perhaps just ``TCP server''. The idea is---a program
called ``TCP server'' waits for connections from the network. When a
client arrives, the TCP server handles the network connection to \lp.
From \lp's perspective, the client is just another keyboard talk to it
directly. This strategy simplifies the implementation of \lp. Both
programs---the TCP server and \lp---have nothing to do with one
another, but their work together make the system work. This
From \lp's perspective, the client is just another keyboard talking to
it directly. This strategy simplifies the implementation of \lp.
Both programs---the TCP server and \lp---have nothing to do with one
another, but their work together makes the service. This
implementation strategy is typically found in UNIX programs.
%
\begin{quote}\small
@ -961,7 +973,8 @@ interpreting such bytes. That's why we call [[read-sequence]] here.
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)
(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)))
@ -1882,71 +1895,74 @@ of trying to stop them.
<<Command post.lisp>>=
(defun cmd-post (r)
(with-auth
(let ((suggested (suggest-message-id)))
(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?)
:data (format nil "Okay, go ahead. Suggested message-id ~a." suggested)))
(let ((tmp (format nil "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 (format nil "Sorry. Your article doesn't conform: ~a." error)))
(t (multiple-value-bind (code reply) (post bs)
(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))))))))
(make-response :code code :request r :data reply)))))))
(ignore-errors (delete-file tmp)))))))
@
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.)
It's time to write the action of posting. The article has already been
streamed to a temporary file by [[nntp-read-article-to-disk]]; we hold
only the headers in memory. [[post]] receives the path and the raw
header bytes, ensures {\tt message-id} and {\tt date} are present
(rewriting the temp file only when a header is missing), then places a
copy into each destination group.
{\bf Note to self}. As professor G.~has written, we'll need to
redesign [[post]] to take two arguments, the article in [[tmp-path]] (its
first argument) and then [[headers-raw]] (its second argument). We
then parse the headers with [[parse-headers]] so that we can grab the
newsgroups to which the article is to be posted so that we handle the
job to [[save-article-insist]]. Of course, we'll need to get a
message-id as well, but let's worry about that later. (Yeah, we need
to optimize [[get-next-article-id]].)
Cross-posting still duplicates the article on the file system for now.
(We will replace the copies with symbolic links once the index work is
finished.)
<<Command post.lisp>>=
(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)))
@ %def post
Notice we parse the article again to extract information from it that
we need during [[post]]. That's not only a waste of time---because we
already did that---, but it makes [[post]] a lot less generic.
Perhaps [[conforms?]] should return a data structure that contains all
that [[post]] needs. Then [[post]] consumes that and saves the
article more easily. That's a better idea. I think [[post]] should
not even use variables such as [[*client*]]. The username to which to
update the last-seen date should be included in the data structure.
However, it's nice to ask for everything and much harder to do it.
Our design so far is that [[conforms?]] return [[T]] when the article
conforms and our writing method is to simply write the sequence of
bytes that the article is. Here's what we should do, without a whole
lot of thinking---make [[post]] consume the sequence of bytes it
consumes today but also make it consume a structure that describes the
entire parsed article. (Keep [[conforms?]] as it is.) This avoids
[[post]] to have to figure out to which groups to post. Regarding the
use of [[update-last-post-date!]], which reads [[*client*]], that's
irrelevant: some procedure must read [[*client*]]; if it's [[post]]
itself or some higher-level other, some procedure must do it.
<<Command post.lisp>>=
(defun update-last-post-date! (username)
(let ((u (get-account username)))
@ -1955,53 +1971,51 @@ itself or some higher-level other, some procedure must do it.
The job of [[save-article-try]] is to atomically allocate an article
name in a group. The atomicity is achieved with [[:if-exists]] in the
[[with-open-file]] macro. When [[if:-exists]] is used, the {\tt open}
system call uses the flag \verb|O_EXCL|, given us an atomic operation.
So, the first [[with-open-file]] allocates the name. If successful,
we take our time writing the article to the temporary file and we
atomically rename it at the end. We should close [[name]] before
trying to [[rename-no-extention]]---on UNIX systems, renaming an open
target might be okay, but that's not allowed on Windows systems. Even
though we have no interest in running \Lp\ on Windows, closing before
renaming it sounds more like the Right Thing to do.
[[with-open-file]] macro. When [[if-exists]] is {\tt nil}, the {\tt open}
system call uses the flag \verb|O_EXCL|, giving us an atomic operation.
So the first [[with-open-file]] allocates the name. If successful, we
copy the already-streamed article from [[src-path]] into a temporary
file next to it and atomically rename it into place.
<<Command post.lisp>>=
(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)
(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)))
(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)))
(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)))
@ %def save-article-try
The procedure [[save-article-insist]] insists on calling
[[save-article-try]] until it finds an article name that has not been
allocated. Notice that the argument [[name]] is an integer, so
[[name]] is incremented at each iteration.
allocated. The argument [[name]] is an integer, incremented at each
iteration (and it's the loop for x from x that makes the increments).
<<Command post.lisp>>=
(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)
@ -2020,7 +2034,126 @@ 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 ()
(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))
(with-open-file (out tmp-path
:direction :output
:element-type '(unsigned-byte 8)
: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 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
@ -2031,7 +2164,7 @@ our accumulated list of lines.
:fill-pointer 0)))
(loop
(let ((ls (nntp-read-line)))
(stderr "nntp-read-line: [~A]" ls)
;(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)
@ -2065,97 +2198,56 @@ stored in this buffer.
(nntp-read-line-buffered s *network-buffer*))
@ %def *network-buffer*
Why do we need a fast procedure here? Because io is the slowest thing
Why do we need a fast procedure here? Because I/O 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.
There is only one line-reading path. Bytes always land in
[[*network-buffer*]]; [[find-lf]] and [[extract-line]] do the framing
work; the sole branch is inside [[fetch-more-bytes]], which prefers a
raw POSIX {\tt read(2)} and falls back to a [[read-byte]] loop only
when the stream has no underlying file descriptor (Gray streams under
SLIME, string streams in tests, and the like). Terminal sessions and
{\tt tcpserver} sockets both take the fast path.
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.
The NNTP protocol establishes that line termination is done with
\verb|\r\n|, but we also accept a bare \verb|\n| because we talk to the
server from the command line with tools that do not always send
CRLF. [[extract-line]] strips a preceding CR when it is present, so
both terminators produce the same clean line of bytes.
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.
is an entire small program with a library of helpers. The main
program sits at the bottom. We begin by looking for a linefeed in the
buffer. If there is one, an entire line is ready to be extracted. If
there isn't, the buffer is either empty or holds only a partial line;
in either case we refill.
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.
What does refilling do? First it checks that we still have room---a
pathological line that never ends must not grow the buffer forever; we
signal an error and let [[main-loop]] decide what to do. Next, any
bytes that already form a partial line are slid to the front of the
buffer with [[replace]] (a memmove). Then [[fetch-more-bytes]] obtains
more data. Finally we search again for a linefeed and either extract
the completed line or recurse to refill once more.
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.
A partial line left in the buffer after an EOF is returned to the
caller; the caller should treat it as a broken client and close the
connection. We deliver everything we have, even when the peer has
already gone away.
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.
The only asymmetry that remains is how bytes arrive. [[%unix-read]]
peels the stream with [[fd-stream-of]] until it finds an
{\tt sb-sys:fd-stream}, then issues a single POSIX {\tt read(2)}.
That path is taken for ordinary terminals and for sockets handed to us
by {\tt tcpserver}. When the stream is a Gray stream (no file
descriptor anywhere in its wrapper chain), [[fd-stream-of]] signals a
{\tt type-error}; [[fetch-more-bytes]] catches it and falls back to
[[%portable-read]], a [[read-byte]] loop that blocks for the first
byte and then slurps whatever is immediately available. The contract
is identical: return as soon as at least one byte is ready. The
fallback costs nothing on the path we care about---human typing or
SLIME---and keeps the framing logic completely shared.
<<Command post.lisp>>=
(defun nntp-read-line-buffered (stream buffer)
@ -2202,62 +2294,10 @@ productivity and education.
(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))))
@ -2309,30 +2349,7 @@ productivity and education.
(two-way-stream (fd-stream-of (two-way-stream-input-stream stream)))))
@ %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.
{\bf Note to self}. Let's not allow a large line. If a line is too
large, we should just truncate it. Also, let's try to avoid this
branching out. We can probably find a solution that's general enough
for both terminal and socket.
<<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 list->bytes (ls)
(mapcar #'data->bytes ls))
@ -2387,7 +2404,7 @@ for both terminal and socket.
(defun bytes->string (ls)
(map 'string #'code-char ls))
@ %def nntp-read-line nntp-read-article
@
{\bf Does the article conform?} RFC 5536 obliges every article to
have exactly \verb|date|, \verb|from|, \verb|message-id|,
@ -2423,16 +2440,21 @@ unclear right now what the wise measure is, so we'll keep on moving.
<<Does an article conform?.lisp>>=
(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-headers (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)))
(return (format nil "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
(let ((ngs (newsgroups-header->list (get-header "newsgroups" headers)))
(ngs-dont-exist nil))
@ -2555,19 +2577,29 @@ 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 ((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 (format nil "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 (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)))
(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))))))
@ %def notify-group-created notify-user-created
\section{Algorithm of {\tt split-vector}}
@ -2981,12 +3013,12 @@ used to invoke [[renameat2]] through the [[cffi]], but we don't use it
any more.
<<Macros.lisp>>=
(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))