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/build-index-from-fs.lisp \
scripts/cron-remove-inactive-users.lisp \ scripts/cron-remove-inactive-users.lisp \
scripts/migrate-add-creation-date.lisp \ scripts/migrate-add-creation-date.lisp \
version.lisp version.lisp TAGS
version.lisp: loop.lisp version.lisp: loop.lisp
echo "(in-package :loop)" > version.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 John too will get all the messages. If anyone violates this rule of
replying to everyone involved, the loop is broken. 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] \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.} \caption{Gnus, a news reader embedded in the GNU EMACS text editor.}
\label{fg:gnus} \label{fg:gnus}
\end{figure} \end{figure}
\begin{figure}[!htb] %% \begin{figure}[!htb]
\centering \includegraphics[width=0.8\linewidth]{images/tbird-summary.png} %% \centering \includegraphics[width=0.8\linewidth]{images/tbird-summary.png}
\caption{Thunderbird, a news reader produced by the Mozilla Foundation.} %% \caption{Thunderbird, a news reader produced by the Mozilla Foundation.}
\label{fg:bird} %% \label{fg:bird}
\end{figure} %% \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] \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.} \caption{Sylpheed, a news reader produced by Hiroyuki Yamamoto.}
\label{fg:sylpheed} \label{fg:sylpheed}
\end{figure} \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 wrappers'' or perhaps just ``TCP server''. The idea is---a program
called ``TCP server'' waits for connections from the network. When a called ``TCP server'' waits for connections from the network. When a
client arrives, the TCP server handles the network connection to \lp. client arrives, the TCP server handles the network connection to \lp.
From \lp's perspective, the client is just another keyboard talk to it From \lp's perspective, the client is just another keyboard talking to
directly. This strategy simplifies the implementation of \lp. Both it directly. This strategy simplifies the implementation of \lp.
programs---the TCP server and \lp---have nothing to do with one Both programs---the TCP server and \lp---have nothing to do with one
another, but their work together make the system work. This another, but their work together makes the service. This
implementation strategy is typically found in UNIX programs. implementation strategy is typically found in UNIX programs.
% %
\begin{quote}\small \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." 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) (with-open-file (in path :element-type '(unsigned-byte 8) :if-does-not-exist nil)
(when in (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)) :adjustable t :fill-pointer 0))
(buffer (make-array 8192 :element-type '(unsigned-byte 8))) (buffer (make-array 8192 :element-type '(unsigned-byte 8)))
(delim #(13 10 13 10))) (delim #(13 10 13 10)))
@ -1882,71 +1895,74 @@ of trying to stop them.
<<Command post.lisp>>= <<Command post.lisp>>=
(defun cmd-post (r) (defun cmd-post (r)
(with-auth (with-auth
(let ((suggested (suggest-message-id)))
(send-response! (send-response!
(make-response (make-response
:code 340 :code 340
:data (format nil "Okay, go ahead. Suggested message-id ~a." :data (format nil "Okay, go ahead. Suggested message-id ~a." suggested)))
(suggest-message-id)))) (let ((tmp (format nil "post-~a.tmp" (random-string 12))))
(let* ((bs (nntp-read-article))) (unwind-protect
(multiple-value-bind (okay? error) (conforms? bs) (progn
(cond ((not okay?) (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 (make-response
:code 400 :request r :code 400 :request r
:data (format nil "Sorry. Your article doesn't conform: ~a." error))) :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*)) (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 It's time to write the action of posting. The article has already been
is cross-posting. First, notice that we're---so far---duplicating streamed to a temporary file by [[nntp-read-article-to-disk]]; we hold
articles on the file system. (We will undo that once we reimplement only the headers in memory. [[post]] receives the path and the raw
our index. More to follow.) 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 Cross-posting still duplicates the article on the file system for now.
redesign [[post]] to take two arguments, the article in [[tmp-path]] (its (We will replace the copies with symbolic links once the index work is
first argument) and then [[headers-raw]] (its second argument). We finished.)
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]].)
<<Command post.lisp>>= <<Command post.lisp>>=
(defun post (bs) (defun post (tmp-path headers-raw)
(let* ((parsed (parse-article bs)) (let* ((headers-str (map 'string #'code-char
(ngs (newsgroups-header->list (subseq headers-raw 0 (max 0 (- (length headers-raw) 4)))))
(get-header "newsgroups" (parse-headers (article-headers parsed))))) (headers (parse-headers headers-str))
(a (ensure-date (ensure-mid bs))) (ngs (newsgroups-header->list (get-header "newsgroups" headers)))
(mid (extract-mid a))) (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) (dolist (ng ngs)
(save-article-insist ng (get-next-article-id ng) a mid)) (save-article-insist ng (get-next-article-id ng) tmp-path))
(values 240 (data "Thank you! Your article has been saved.")))) (values 240 "Thank you! Your article has been saved.")))
(defun newsgroups-header->list (s) (defun newsgroups-header->list (s)
(mapcar #'(lambda (n) (str:trim (string-downcase n))) (str:split "," s))) (mapcar #'(lambda (n) (str:trim (string-downcase n))) (str:split "," s)))
@ %def post @ %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>>= <<Command post.lisp>>=
(defun update-last-post-date! (username) (defun update-last-post-date! (username)
(let ((u (get-account 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 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 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} [[with-open-file]] macro. When [[if-exists]] is {\tt nil}, the {\tt open}
system call uses the flag \verb|O_EXCL|, given us an atomic operation. system call uses the flag \verb|O_EXCL|, giving us an atomic operation.
So, the first [[with-open-file]] allocates the name. If successful, So the first [[with-open-file]] allocates the name. If successful, we
we take our time writing the article to the temporary file and we copy the already-streamed article from [[src-path]] into a temporary
atomically rename it at the end. We should close [[name]] before file next to it and atomically rename it into place.
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.
<<Command post.lisp>>= <<Command post.lisp>>=
(defun rename-no-extension (old new) (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)) (let ((name (format nil "~a" name-try))
(tmp (format nil "~a.tmp" name-try))) (tmp (format nil "~a.tmp" name-try)))
(with-open-file (with-open-file
(s name (s name
:direction :output :direction :output
:if-exists nil ;; an atomic operation :if-exists nil ; atomic O_EXCL allocation
:if-does-not-exist :create) :if-does-not-exist :create)
(when (null s) (when (null s)
(progn
(stderr "warning: save-article-try: ~a exists~%" name) (stderr "warning: save-article-try: ~a exists~%" name)
(return-from save-article-try 'name-exists)))) (return-from save-article-try 'name-exists)))
(with-open-file (stderr "going to rename in save-article-try~%")
(s tmp ;; Because of my mess with directory paths, I'm having to do the
:direction :output ;; ../../ here. This is bad design. We need to find a solution
:if-exists :error ;; for this. But don't come up with the use
:if-does-not-exist :create ;; absolute-paths-solution. Relative paths is always better.
:element-type '(unsigned-byte 8)) (stderr "current-directory: ~a~%" (uiop:getcwd))
(write-sequence bs s)) (stderr "default-pathname: ~a~%" *default-pathname-defaults*)
(rename-no-extension tmp name))) (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 @ %def save-article-try
The procedure [[save-article-insist]] insists on calling The procedure [[save-article-insist]] insists on calling
[[save-article-try]] until it finds an article name that has not been [[save-article-try]] until it finds an article name that has not been
allocated. Notice that the argument [[name]] is an integer, so allocated. The argument [[name]] is an integer, incremented at each
[[name]] is incremented at each iteration. iteration (and it's the loop for x from x that makes the increments).
<<Command post.lisp>>= <<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 (loop for name from name do
(in-dir (format nil "groups/~a/" g) (in-group g
(when (not (eql 'name-exists (save-article-try name a))) (when (not (eql 'name-exists (save-article-try name src-path)))
(return (values name (insert-index message-id g (fmt "~a" name)))))))) (return (values name t))))))
(defun get-next-article-id (g) (defun get-next-article-id (g)
(multiple-value-bind (low high len) (group-high-low 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. our accumulated list of lines.
<<Command post.lisp>>= <<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 ;; Returns a vector of bytes: the article, CRLF between lines, up to
;; (excluding) the "." terminator. VECTOR-PUSH-EXTEND grows the ;; (excluding) the "." terminator. VECTOR-PUSH-EXTEND grows the
;; buffer in amortized O(1) per push, so total cost is O(size of 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))) :fill-pointer 0)))
(loop (loop
(let ((ls (nntp-read-line))) (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 (eq ls :eof) (error 'end-of-file :stream *standard-input*))
(when (end-of-article? ls) (return buf)) (when (end-of-article? ls) (return buf))
(map nil (lambda (b) (vector-push-extend b buf)) ls) (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*)) (nntp-read-line-buffered s *network-buffer*))
@ %def *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 in computers. For instance, if we allow attachments in posts (which
we don't), the performance penalty is clearly noticeable. we don't), the performance penalty is clearly noticeable.
The procedure [[nntp-read-line-buffered]] is pretty much as fast as we There is only one line-reading path. Bytes always land in
can get, but it's considerably more complicated. One part of the [[*network-buffer*]]; [[find-lf]] and [[extract-line]] do the framing
complication is that, because information comes from the network, we work; the sole branch is inside [[fetch-more-bytes]], which prefers a
could get partial lines. I must also say that I was not able to get a raw POSIX {\tt read(2)} and falls back to a [[read-byte]] loop only
general solution for both network and keyboard connections, which is when the stream has no underlying file descriptor (Gray streams under
why I'm using [[interactive-stream-p]] to detect whether I'm in a SLIME, string streams in tests, and the like). Terminal sessions and
terminal-interactive session. The NNTP protocol establishes that line {\tt tcpserver} sockets both take the fast path.
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 The NNTP protocol establishes that line termination is done with
collect it up into the line-bytes array, which is the business of \verb|\r\n|, but we also accept a bare \verb|\n| because we talk to the
[[get-interactive-line]]. When not interactively, we'll have to face server from the command line with tools that do not always send
the complications. CRLF. [[extract-line]] strips a preceding CR when it is present, so
both terminators produce the same clean line of bytes.
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 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 is an entire small program with a library of helpers. The main
bottom. We begin by trying to find a linefeed in the buffer. If program sits at the bottom. We begin by looking for a linefeed in the
there is one, it's because there's an entire line to be extracted and buffer. If there is one, an entire line is ready to be extracted. If
consumed. If there isn't a newline, it's either because the buffer is there isn't, the buffer is either empty or holds only a partial line;
empty or because there's only a partial line in the buffer. A partial in either case we refill.
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 What does refilling do? First it checks that we still have room---a
need to read more data and write it out onto the buffer. The writing pathological line that never ends must not grow the buffer forever; we
itself is actually done by [[read-sequence]], so our job is just to do signal an error and let [[main-loop]] decide what to do. Next, any
the bookkeeping. The very first thing to be done is to make sure that bytes that already form a partial line are slid to the front of the
we have enough space for the next [[read-sequence]]. If someone sends buffer with [[replace]] (a memmove). Then [[fetch-more-bytes]] obtains
a very long line, then we might run out of space. We detect that by more data. Finally we search again for a linefeed and either extract
checking whether [[remaining]] is at the very end of the the buffer. the completed line or recurse to refill once more.
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 A partial line left in the buffer after an EOF is returned to the
stored in the buffer after one or a few complete lines. To view this caller; the caller should treat it as a broken client and close the
situation properly, we should explain how [[extract-line]] connection. We deliver everything we have, even when the peer has
works. Suppose the buffer has been filled with 2 lines and a third already gone away.
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 The only asymmetry that remains is how bytes arrive. [[%unix-read]]
be completed, we will return that partial line to the caller and it's peels the stream with [[fd-stream-of]] until it finds an
up to the caller to decide what to do with it. Probably, the best {\tt sb-sys:fd-stream}, then issues a single POSIX {\tt read(2)}.
thing to do is to log the fact and close the connection. A partial That path is taken for ordinary terminals and for sockets handed to us
line really indicates a client in trouble---in fact, the client itself by {\tt tcpserver}. When the stream is a Gray stream (no file
has already closed the connection, since we read eof. Nevertheless, descriptor anywhere in its wrapper chain), [[fd-stream-of]] signals a
it is our job to deliver everything we have to the caller, so we must {\tt type-error}; [[fetch-more-bytes]] catches it and falls back to
do our duty here. [[%portable-read]], a [[read-byte]] loop that blocks for the first
byte and then slurps whatever is immediately available. The contract
If new bytes arrived, then we just search for a linefeed and extract is identical: return as soon as at least one byte is ready. The
the new line. We should inquiry here why we're trying to extract a fallback costs nothing on the path we care about---human typing or
line in two places: after refilling the buffer and in the main SLIME---and keeps the framing logic completely shared.
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>>= <<Command post.lisp>>=
(defun nntp-read-line-buffered (stream buffer) (defun nntp-read-line-buffered (stream buffer)
@ -2202,62 +2294,10 @@ productivity and education.
(extract-line lf-pos) (extract-line lf-pos)
(refill-and-extract-line)))))) (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) (defun fetch-more-bytes (stream buf start max-count)
;; Attempt the fast, native C-level POSIX read. If `fd-stream-of` "Try the fast POSIX path; fall back to a portable read-byte loop
;; fails to find an underlying file descriptor (e.g., SLIME REPL when the stream has no underlying fd (Gray streams under SLIME,
;; streams), it signals a TYPE-ERROR. We catch it and fallback. string streams in tests, etc.)."
;; This is kinda silly. Let's remove %portable-read because we
;; really don't care about the SMILE REPL, though we use it.
(handler-case (%unix-read stream buf start max-count) (handler-case (%unix-read stream buf start max-count)
(type-error () (type-error ()
(%portable-read stream buf start max-count)))) (%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))))) (two-way-stream (fd-stream-of (two-way-stream-input-stream stream)))))
@ %def nntp-read-line-buffered @ %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>>= <<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) (defun list->bytes (ls)
(mapcar #'data->bytes ls)) (mapcar #'data->bytes ls))
@ -2387,7 +2404,7 @@ for both terminal and socket.
(defun bytes->string (ls) (defun bytes->string (ls)
(map 'string #'code-char ls)) (map 'string #'code-char ls))
@ %def nntp-read-line nntp-read-article @
{\bf Does the article conform?} RFC 5536 obliges every article to {\bf Does the article conform?} RFC 5536 obliges every article to
have exactly \verb|date|, \verb|from|, \verb|message-id|, 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>>= <<Does an article conform?.lisp>>=
(defun conforms? (bs) (defun conforms? (bs)
(catch 'article-syntax-error ;; parse-headers might throw "Convenience wrapper: parse the in-memory article and check headers."
(let ((headers (parse-headers (article-headers (parse-article bs))))) (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)) (let ((result (dolist (h (headers-required-from-clients))
(when (not (lookup h headers)) (when (not (lookup h headers))
(return (format nil "missing the /~a/ header" h))))) (return (format nil "missing the /~a/ header" h))))))
(content-type (get-header "content-type" headers)))
(cond (cond
((stringp result) (values nil result)) ((stringp result) (values nil result))
;((not (text/plain? content-type))
; (values nil (format nil "content-type must be plain/text, but it's ~a" content-type)))
(t (t
(let ((ngs (newsgroups-header->list (get-header "newsgroups" headers))) (let ((ngs (newsgroups-header->list (get-header "newsgroups" headers)))
(ngs-dont-exist nil)) (ngs-dont-exist nil))
@ -2555,19 +2577,29 @@ invitations {\em et cetera} are published there.
(defun post-notification (&key subject body) (defun post-notification (&key subject body)
(in-groups (ensure-directories-exist "local.control.news/")) (in-groups (ensure-directories-exist "local.control.news/"))
(when (group? "local.control.news") (when (group? "local.control.news")
(let ((a (make-news :subject subject :body body))) (let ((tmp (format nil "notify-~a.tmp" (random-string 10)))
(post (concatenate 'vector (article-headers a) (crlf) (article-body a) (crlf)))))) (mid (suggest-message-id)))
(unwind-protect
(defun make-news (&key subject body) (progn
(make-article (with-open-file (out tmp
:headers (data :direction :output
(add-crlf-between :element-type '(unsigned-byte 8)
(mapcar :if-exists :supersede
#'(lambda (p) (data (format nil "~a: ~a" (car p) (cdr p)))) :if-does-not-exist :create)
`(("from" . "Loop") (flet ((wline (s)
("subject" . ,subject) (write-sequence (map 'vector #'char-code s) out)
("newsgroups" . "local.control.news"))))) (write-byte 13 out) (write-byte 10 out)))
:body (data body))) (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 @ %def notify-group-created notify-user-created
\section{Algorithm of {\tt split-vector}} \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. any more.
<<Macros.lisp>>= <<Macros.lisp>>=
(defmacro in-tmp (&rest body) `(in-dir "tmp/" ,@body))
(defmacro in-groups (&rest body) `(in-dir "groups/" ,@body)) (defmacro in-groups (&rest body) `(in-dir "groups/" ,@body))
(defun in-group-lambda (g fn) (in-dir g (funcall fn))) (defun in-group-lambda (g fn) (in-dir g (funcall fn)))
(defmacro in-group (g &rest body) (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) (defmacro with-group (g r &rest body)
(let ((g-var (gensym)) (let ((g-var (gensym))