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

Rewrites and presents the section on streaming articles to disk.

Browse source
This commit is contained in:
Circling Skies 2026-08-05 16:04:42 -03:00
parent efb1410785
commit 53072ef46f
2 changed files with 632 additions and 755 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

632
loop.lisp
View file

@ -27,7 +27,7 @@
(defparameter *default-database* nil) (defparameter *default-database* nil)
(defstruct command fn verb description) (defstruct command fn verb description)
(defparameter *commands-assoc* nil) (defparameter *commands-assoc* nil)
(defstruct article headers body) (defstruct article head body)
(defparameter *months-inactive-allowed* 3) (defparameter *months-inactive-allowed* 3)
(defparameter *months-never-logged-in* 1) (defparameter *months-never-logged-in* 1)
(defparameter *enable-nntp-repl* t) (defparameter *enable-nntp-repl* t)
@ -89,7 +89,7 @@
:data "unrecognized command" :data "unrecognized command"
:request r)) :request r))
:verb 'unrecognized :verb 'unrecognized
:description "a command for all commands typed wrong"))) :description "a command for all commands typed wrongly")))
(or (cdr cmd) (unrecognized-command))))) (or (cdr cmd) (unrecognized-command)))))
(defmacro in-dir (dir &rest body) (defmacro in-dir (dir &rest body)
@ -97,12 +97,14 @@
(uiop:with-current-directory (,dir) (uiop:with-current-directory (,dir)
,@body))) ,@body)))
(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))
@ -111,7 +113,7 @@
(,r-var ,r)) (,r-var ,r))
(if (not (group? ,g-var)) (if (not (group? ,g-var))
(make-response :code 411 :request ,r-var (make-response :code 411 :request ,r-var
:data (format nil "no such group ``~a''" ,g-var)) :data (fmt "no such group ``~a''" ,g-var))
(progn ,@body))))) (progn ,@body)))))
(defmacro with-n-args (n r &rest body) (defmacro with-n-args (n r &rest body)
@ -187,7 +189,7 @@
(make-response :code (or code 400) :data msg :request r)) (make-response :code (or code 400) :data msg :request r))
(defun integer->string (n) (defun integer->string (n)
(format nil "~a" n)) (fmt "~a" n))
(defun mkstr (&rest args) ;; a utility (defun mkstr (&rest args) ;; a utility
(with-output-to-string (s) (with-output-to-string (s)
@ -200,7 +202,7 @@
(vector 13 10)) (vector 13 10))
(defun crlf-string () (defun crlf-string ()
(format nil "~c~c" #\return #\linefeed)) (fmt "~c~c" #\return #\linefeed))
(defun flatten (obj) (defun flatten (obj)
(do* ((result (list obj)) (do* ((result (list obj))
@ -222,11 +224,6 @@
(let ((expr (read))) (let ((expr (read)))
(if (eq 'quit expr) (if (eq 'quit expr)
(progn (progn
;; At this point, there's \r\n still in the stdin due
;; to read having returned a symbol followed by a line
;; termination, so we must wipe that out or nntp-read-line
;; will find an empty line after this.
(clear-input)
(return (return
(make-response (make-response
:code 200 :request r :code 200 :request r
@ -253,33 +250,6 @@
:multi-line (response-multi-line r) :multi-line (response-multi-line r)
:request (response-request r))) :request (response-request r)))
(defun append-crlf-if-needed (seq)
(cond
((stringp seq)
(append-crlf-if-needed (string->bytes seq)))
((listp seq)
(append seq
(when (not (= (car (last seq)) 10))
(list 13 10))))
(t (error (format nil "append-crlf-if-needed: unsupported type: ~a" (type-of seq))))))
(defun send-response! (r)
;; Write the response code and a space
(send-chunk! (integer->string (response-code r)) *standard-output*)
(send-chunk! " " *standard-output*)
;; Write the actual payload (status text + article body)
(send-chunk! (response-data r) *standard-output*)
;; Ensure a CRLF at the end of the payload
(send-chunk! (crlf) *standard-output*)
(when (response-multi-line r)
(send-chunk! "." *standard-output*)
(send-chunk! (crlf) *standard-output*))
(force-output)
r)
(defun my-write (ls-of-bytes s)
(write-sequence ls-of-bytes s))
(defun parse-request (r) (defun parse-request (r)
(let* ((collapsed-s (str:collapse-whitespaces (request-said r))) (let* ((collapsed-s (str:collapse-whitespaces (request-said r)))
(ls (str:split " " collapsed-s :omit-nulls 'please))) (ls (str:split " " collapsed-s :omit-nulls 'please)))
@ -466,19 +436,17 @@
(let ((pos (search #(13 10 13 10) v))) (let ((pos (search #(13 10 13 10) v)))
(if pos (if pos
(make-article (make-article
:headers (map 'string #'code-char (subseq v 0 pos)) :head (map 'string #'code-char (subseq v 0 pos))
;; Create a zero-copy window into the original byte array.
:body (make-array (- (length v) (+ pos 4)) :body (make-array (- (length v) (+ pos 4))
:element-type (array-element-type v) :element-type (array-element-type v)
:displaced-to v :displaced-to v
:displaced-index-offset (+ pos 4))) :displaced-index-offset (+ pos 4)))
;; What should we do if no body is found? Is that legal NNTP?
(make-article (make-article
:headers (map 'string #'code-char v) :head (map 'string #'code-char v)
:body (make-array 0 :element-type (array-element-type v)))))) :body (make-array 0 :element-type (array-element-type v))))))
(defun hs-space-collapsed (hs) (defun hs-space-collapsed (hs)
(cl-ppcre:regex-replace-all (format nil "~a[ ~a]+" (crlf-string) #\tab) hs " ")) (cl-ppcre:regex-replace-all (fmt "~a[ ~a]+" (crlf-string) #\tab) hs " "))
(defun hs-lines (lines) (str:split (crlf-string) lines)) (defun hs-lines (lines) (str:split (crlf-string) lines))
@ -487,10 +455,10 @@
(pos (search ":" h))) (pos (search ":" h)))
(when (null pos) (when (null pos)
(throw 'article-syntax-error (throw 'article-syntax-error
(values nil (format nil "missing colon in header |~a|" h)))) (values nil (fmt "missing colon in header |~a|" h))))
(when (<= (length h) (+ 2 pos)) (when (<= (length h) (+ 2 pos))
(throw 'article-syntax-error (throw 'article-syntax-error
(values nil (format nil "empty header ~a" h)))) (values nil (fmt "empty header ~a" h))))
(multiple-value-bind (key val) (multiple-value-bind (key val)
(values (subseq h 0 pos) (subseq h (+ 2 pos))) (values (subseq h 0 pos) (subseq h (+ 2 pos)))
(cons (str:downcase key) val)))) (cons (str:downcase key) val))))
@ -508,68 +476,88 @@
(defun fetch-headers (g i) (defun fetch-headers (g i)
(let* ((a-string (fetch-article g i)) (let* ((a-string (fetch-article g i))
(a-parsed (parse-article a-string)) (a-parsed (parse-article a-string))
(headers (parse-headers (article-headers a-parsed)))) (headers (parse-headers (article-head a-parsed))))
(enrich-headers headers a-string a-parsed))) (enrich-headers headers a-string a-parsed)))
(defun enrich-headers (hs a-raw a-parsed) (defun enrich-headers (hs a-raw a-parsed)
(append hs (append hs
`(("line-count" . ,(format nil "~a" (nlines (article-body a-parsed)))) `(("line-count" . ,(fmt "~a" (nlines (article-body a-parsed))))
("byte-count" . ,(format nil "~a" (length a-raw)))))) ("byte-count" . ,(fmt "~a" (length a-raw))))))
(defun nlines (v) (defun nlines (v)
(loop for b across v (loop for b across v
count (= b 10))) count (= b 10)))
(defun read-headers-raw (path) (defun extract-mid (a)
"Reads from PATH chunk by chunk until CRLF CRLF is found. (lookup "message-id" (parse-headers (article-head (parse-article a)))))
Returns the byte vector of the headers. Closes the file immediately."
(with-open-file (in path :element-type '(unsigned-byte 8) :if-does-not-exist nil)
(when in
(let ((acc (make-array 8192 :element-type '(unsigned-byte 8)
:adjustable t :fill-pointer 0))
(buffer (make-array 8192 :element-type '(unsigned-byte 8)))
(delim #(13 10 13 10)))
(loop
(let ((n (read-sequence buffer in)))
(when (zerop n)
(return acc)) ; EOF reached without body delimiter
;; Append new bytes to our accumulator
(let ((start-search (length acc)))
(dotimes (i n)
(vector-push-extend (aref buffer i) acc))
;; Search for the delimiter. We subtract 3 from our start
;; index to catch delimiters that span across the chunk boundary.
(let ((pos (search delim acc :start2 (max 0 (- start-search 3)))))
(when pos
;; Return exactly up to the end of the delimiter
(return (subseq acc 0 (+ pos 4))))))))))))
(defun lookup (key table)
(cdr (assoc key table :test #'string=)))
(defstruct file-stream-payload (defstruct file-stream-payload
(path "" :type string) (path "" :type string)
(start-pos 0 :type integer)) (start-pos 0 :type integer))
(defun fetch-article (g i) (defun fetch-article (g i)
(in-groups (in-group g
(read-headers-raw (format nil "~a/~a" g i)))) (read-headers-raw (fmt "~a" i))))
(defun read-file-raw (path) (defun read-headers-raw (path)
(with-open-file (with-open-file (in path :element-type '(unsigned-byte 8) :if-does-not-exist :error)
(in path
:element-type '(unsigned-byte 8)
:if-does-not-exist nil)
(when in (when in
(let* ((size (sb-posix:stat-size (sb-posix:stat path))) (let ((acc (make-array 8192
(a (make-array size))) :element-type '(unsigned-byte 8)
(read-sequence a in) :adjustable t :fill-pointer 0))
a)))) (buffer (make-array 8192 :element-type '(unsigned-byte 8)))
(sep #(13 10 13 10)))
(loop
(let ((n (read-sequence buffer in)))
(when (zerop n)
(return acc)) ; eof without having found the separator
(let ((start-search (length acc)))
(dotimes (i n) ; copy all bytes to the accumulator
(vector-push-extend (aref buffer i) acc))
;; Search for the separator. We subtract 3 from our
;; start index to catch a separator that was broken into
;; two calls of read-sequence.
(let ((pos (search sep acc :start2 (max 0 (- start-search 3)))))
(when pos
(return (subseq acc 0 (+ pos 4))))))))))))
(defun extract-mid (a) (defun stream-file-to-socket (payload out-stream)
(lookup "message-id" (parse-headers (article-headers (parse-article a))))) "Opens the file, seeks to the start of the body, and streams to the socket
while applying on-the-fly NNTP dot-stuffing."
(with-open-file (in (file-stream-payload-path payload)
:element-type '(unsigned-byte 8))
(file-position in (file-stream-payload-start-pos payload))
(let ((buf (make-array 8192 :element-type '(unsigned-byte 8)))
(at-line-start t)) ; The body implicitly starts at the beginning of a line
(loop for n = (read-sequence buf in)
while (plusp n)
do (loop for i from 0 below n
for byte = (aref buf i)
do (when (and at-line-start (= byte 46)) ; 46 is '.'
(write-byte 46 out-stream))
(write-byte byte out-stream)
(setf at-line-start (= byte 10)))))))
(defun lookup (key table) (defun send-chunk! (chunk s)
(cdr (assoc key table :test #'string=))) (etypecase chunk
(string (write-sequence (string->bytes chunk) s))
(vector (write-sequence chunk s))
(list (dolist (c chunk) (send-chunk! c s)))
(integer (write-byte chunk s))
(file-stream-payload (stream-file-to-socket chunk s))))
(defun send-response! (r)
(send-chunk! (integer->string (response-code r)) *standard-output*)
(send-chunk! " " *standard-output*)
(send-chunk! (response-data r) *standard-output*)
(send-chunk! (crlf) *standard-output*)
(when (response-multi-line r)
(send-chunk! "." *standard-output*)
(send-chunk! (crlf) *standard-output*))
(force-output)
r)
(defun dispatch (r) (defun dispatch (r)
(let* ((verb (request-verb r))) (let* ((verb (request-verb r)))
@ -591,7 +579,7 @@
((string= cmd "USER") ((string= cmd "USER")
(setf (client-username *client*) arg) (setf (client-username *client*) arg)
(make-response :code 381 :request r (make-response :code 381 :request r
:data (format nil "Hey, ~a, please tell us your password." arg))) :data (fmt "Hey, ~a, please tell us your password." arg)))
((string= cmd "PASS") ((string= cmd "PASS")
(if (authinfo-check (client-username *client*) arg) (if (authinfo-check (client-username *client*) arg)
(progn (progn
@ -630,7 +618,7 @@
(t (multiple-value-bind (group n-str) (lookup-index n-or-mid) (t (multiple-value-bind (group n-str) (lookup-index n-or-mid)
(if (and group n-str) (if (and group n-str)
(funcall fn-name r group n-str) (funcall fn-name r group n-str)
(bad-input r (format nil "Unknown article ~a." n-or-mid)))))))) (bad-input r (fmt "Unknown article ~a." n-or-mid))))))))
(t (bad-input r "No, no: it takes at most two arguments."))))))) (t (bad-input r "No, no: it takes at most two arguments.")))))))
(defun cmd-head (r) (defun cmd-head (r)
@ -653,31 +641,31 @@
(defun typical-cmd-response (code r g i requested-part) (defun typical-cmd-response (code r g i requested-part)
(handler-case (handler-case
(let* ((path (format nil "groups/~a/~a" g i)) (let* ((path (fmt "groups/~a/~a" g i))
(headers-raw (read-headers-raw path))) (headers-raw (read-headers-raw path)))
(if (null headers-raw) (if (null headers-raw)
(make-response :code 400 :request r :data (format nil "article ~a/~a does not exist" g i)) (make-response :code 400 :request r :data (fmt "article ~a/~a does not exist" g i))
(let* ((a (parse-article headers-raw)) (let* ((a (parse-article headers-raw))
;; FIX: Pass the raw bytes to extract-mid, not the parsed struct ;; FIX: Pass the raw bytes to extract-mid, not the parsed struct
(mid (extract-mid headers-raw)) (mid (extract-mid headers-raw))
(header-length (length headers-raw)) (header-length (length headers-raw))
(payload (payload
(ecase requested-part (ecase requested-part
(:head (article-headers a)) (:head (article-head a))
(:body (make-file-stream-payload :path path :start-pos header-length)) (:body (make-file-stream-payload :path path :start-pos header-length))
(:article (list (article-headers a) (:article (list (article-head a)
(crlf)
(crlf) (crlf)
(make-file-stream-payload :path path :start-pos header-length)))))) (make-file-stream-payload :path path :start-pos header-length))))))
(prepend-response-with (fmt "~a ~a" i mid)
(prepend-response-with (format nil "~a ~a" i mid)
(make-response :multi-line 'yes :code code :request r :data payload))))) (make-response :multi-line 'yes :code code :request r :data payload)))))
(sb-posix:syscall-error (c) (sb-posix:syscall-error (c)
(let ((msg (format nil "article ~a/~a: ~a" g i c))) (let ((msg (fmt "article ~a/~a: ~a" g i c)))
(stderr msg) (stderr msg)
(make-response :code 400 :request r :data msg))) (make-response :code 400 :request r :data msg)))
(error (c) (error (c)
(let ((msg (format nil "unexpected condition when reading article ~a/~a: ~a" g i c))) (let ((msg (fmt "unexpected condition when reading article ~a/~a: ~a" g i c)))
(stderr msg) (stderr msg)
(make-response :code 400 :request r :data msg))))) (make-response :code 400 :request r :data msg)))))
@ -697,7 +685,7 @@
(let ((cur (client-article *client*))) (let ((cur (client-article *client*)))
(make-response :code 223 (make-response :code 223
:request r :request r
:data (format nil "~a ~a" cur (mid-by-name g cur))))) :data (fmt "~a ~a" cur (mid-by-name g cur)))))
(defun mid-by-name (g name) (defun mid-by-name (g name)
(extract-mid (fetch-article g name))) (extract-mid (fetch-article g name)))
@ -744,7 +732,7 @@
(fetch-headers g i))))))))))) (fetch-headers g i)))))))))))
(defun xover-format-line (i hs) (defun xover-format-line (i hs)
(str:concat (format nil "~a~a" i #\tab) (str:concat (fmt "~a~a" i #\tab)
(str:join #\tab (str:join #\tab
(mapcar #'(lambda (h) (get-header h hs)) (mapcar #'(lambda (h) (get-header h hs))
(xover-headers))))) (xover-headers)))))
@ -759,7 +747,7 @@
(with-group g r (with-group g r
(set-group! g) (set-group! g)
(multiple-value-bind (low high len) (group-high-low g) (multiple-value-bind (low high len) (group-high-low g)
(let ((ln (format nil "~a ~a ~a ~a" len low high g))) (let ((ln (fmt "~a ~a ~a ~a" len low high g)))
(setf (client-article *client*) low) (setf (client-article *client*) low)
(make-response :code 211 :request r :data ln)))))))) (make-response :code 211 :request r :data ln))))))))
@ -767,9 +755,6 @@
(in-groups (in-groups
(ignore-errors (directory-p g)))) (ignore-errors (directory-p g))))
(defun xgroup? (g)
(directory-p g))
(defun set-group! (g) (defun set-group! (g)
(setf (client-group *client*) g)) (setf (client-group *client*) g))
(defstruct group name high low) (defstruct group name high low)
@ -785,7 +770,7 @@
(reverse (reverse
(mapcar (mapcar
#'(lambda (g) #'(lambda (g)
(format nil "~a ~a ~a y" (group-name g) (group-high g) (group-low g))) (fmt "~a ~a ~a y" (group-name g) (group-high g) (group-low g)))
ls))) ls)))
(defun build-groups-structs () (defun build-groups-structs ()
@ -891,22 +876,20 @@
(file-namestring s)))) (file-namestring s))))
(defun cmd-help (r) (defun cmd-help (r)
(let ((lines (menu *commands-assoc*))) (labels ((menu (ls)
(prepend-response-with (loop for item in ls
"What's on the menu today?" collect (display-fn item)))
(make-response :code 200 :multi-line 'yes (display-fn (cmd-pair)
:request r (let ((cmd (cdr cmd-pair)))
:data (str:join (crlf-string) lines))))) (fmt "~A ~A"
(command-verb cmd)
(defun menu (ls) (command-description cmd)))))
(loop for item in ls (let ((lines (menu *commands-assoc*)))
collect (display-fn item))) (prepend-response-with
"What's on the menu today?"
(defun display-fn (cmd-pair) (make-response :code 200 :multi-line 'yes
(let ((cmd (cdr cmd-pair))) :request r
(format nil "~A ~A" :data (str:join (crlf-string) lines))))))
(command-verb cmd)
(command-description cmd))))
(defun cmd-quit (r) (defun cmd-quit (r)
(make-response :code 205 :data "Good-bye." :request r)) (make-response :code 205 :data "Good-bye." :request r))
@ -918,17 +901,22 @@
(format-timestring nil (now)))) (format-timestring nil (now))))
(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-head (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 (fmt "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)) (t
; (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))) (let ((ngs (newsgroups-header->list (get-header "newsgroups" headers)))
(ngs-dont-exist nil)) (ngs-dont-exist nil))
(dolist (g ngs) (dolist (g ngs)
@ -936,7 +924,7 @@
(not (group? g))) (not (group? g)))
(push g ngs-dont-exist))) (push g ngs-dont-exist)))
(if (not (zerop (length ngs-dont-exist))) (if (not (zerop (length ngs-dont-exist)))
(values nil (format nil "the ~a ~a just ~a exist" (values nil (fmt "the ~a ~a just ~a exist"
(word-plural (length ngs-dont-exist) "newsgroup") (word-plural (length ngs-dont-exist) "newsgroup")
(str:join ", " (sort ngs-dont-exist #'string<)) (str:join ", " (sort ngs-dont-exist #'string<))
(word-plural (length ngs-dont-exist) "doesn't"))) (word-plural (length ngs-dont-exist) "doesn't")))
@ -955,7 +943,7 @@
'("from" "newsgroups" "subject")) '("from" "newsgroups" "subject"))
(defun suggest-message-id (&optional (n 20)) (defun suggest-message-id (&optional (n 20))
(format nil "<~a@loop>" (random-string n))) (fmt "<~a@loop>" (random-string n)))
(defun random-string (size) (defun random-string (size)
(let* ((universe "abcdefghijklmnopqrstuvwxyz") (let* ((universe "abcdefghijklmnopqrstuvwxyz")
@ -969,7 +957,7 @@
(defun unparse-article (parsed) (defun unparse-article (parsed)
;; 1. Build the new headers as a standard string ;; 1. Build the new headers as a standard string
(let* ((headers-str (with-output-to-string (s) (let* ((headers-str (with-output-to-string (s)
(dolist (h (parse-headers (article-headers parsed))) (dolist (h (parse-headers (article-head parsed)))
(format s "~a: ~a~c~c" (str:capitalize (car h)) (cdr h) #\return #\linefeed)) (format s "~a: ~a~c~c" (str:capitalize (car h)) (cdr h) #\return #\linefeed))
;; Add the final \r\n separating headers from the body ;; Add the final \r\n separating headers from the body
(format s "~c~c" #\return #\linefeed))) (format s "~c~c" #\return #\linefeed)))
@ -979,19 +967,18 @@
:initial-contents (map 'list #'char-code headers-str))) :initial-contents (map 'list #'char-code headers-str)))
;; 3. Get the displaced, zero-copy body array ;; 3. Get the displaced, zero-copy body array
(body-bytes (article-body parsed))) (body-bytes (article-body parsed)))
;; 4. Let SBCL compile this into a fast C-level memcpy
(concatenate '(vector (unsigned-byte 8)) headers-bytes body-bytes))) (concatenate '(vector (unsigned-byte 8)) headers-bytes body-bytes)))
(defun ensure-header (h fn bs) (defun ensure-header (h fn bs)
(let* ((headers (parse-headers (article-headers (parse-article bs))))) (let* ((headers (parse-headers (article-head (parse-article bs)))))
(if (lookup h headers) (if (lookup h headers)
bs bs
(unparse-article (unparse-article
(make-article (make-article
:headers :head
(str:join (crlf-string) (str:join (crlf-string)
(mapcar #'(lambda (h) (mapcar #'(lambda (h)
(format nil "~a: ~a" (car h) (cdr h))) (fmt "~a: ~a" (car h) (cdr h)))
(cons (cons h (funcall fn)) headers))) (cons (cons h (funcall fn)) headers)))
:body (article-body (parse-article bs))))))) :body (article-body (parse-article bs)))))))
@ -999,7 +986,7 @@
(multiple-value-bind (s m h day mon year dow dst-p tz) (multiple-value-bind (s m h day mon year dow dst-p tz)
(get-decoded-time) (get-decoded-time)
(declare (ignore dow dst-p)) (declare (ignore dow dst-p))
(format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d GMT~a" (fmt "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d GMT~a"
year mon day h m s (- tz)))) year mon day h m s (- tz))))
(defun ensure-mid (bs) (defun ensure-mid (bs)
@ -1009,31 +996,57 @@
(ensure-header "date" #'get-date bs)) (ensure-header "date" #'get-date bs))
(defun cmd-post (r) (defun cmd-post (r)
(with-auth (with-auth
(send-response! (let ((suggested (suggest-message-id)))
(make-response (send-response!
:code 340 (make-response
:data (format nil "Okay, go ahead. Suggested message-id ~a." :code 340
(suggest-message-id)))) :data (fmt "Okay, go ahead. Suggested message-id ~a." suggested)))
(let* ((bs (nntp-read-article))) (let ((tmp (fmt "post-~a.tmp" (random-string 12))))
(multiple-value-bind (okay? error) (conforms? bs) (unwind-protect
(cond ((not okay?) (progn
(make-response (in-tmp (nntp-read-article-to-disk tmp))
:code 400 :request r (stderr "finished writing article to disk in tmp/~a~%" tmp)
:data (format nil "Sorry. Your article doesn't conform: ~a." error))) (let* ((headers-raw (in-tmp (read-headers-raw tmp)))
(t (multiple-value-bind (code reply) (post bs) ;; headers-raw includes the terminating CRLF CRLF; strip it
(update-last-post-date! (client-username *client*)) ;; so parse-headers does not see an empty final line.
(make-response :code code :request r :data reply)))))))) (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 (fmt "Sorry. Your article doesn't conform: ~a." error)))
(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)))))))
(ignore-errors (delete-file tmp)))))))
(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)))
@ -1043,57 +1056,63 @@
(setf (account-last-post u) (get-universal-time)))) (setf (account-last-post u) (get-universal-time))))
(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)
(let ((name (format nil "~a" name-try)) (stderr "going to try to save ~a with name ~a~%" src-path name-try)
(tmp (format nil "~a.tmp" name-try))) (let ((name (fmt "~a" name-try))
(with-open-file (tmp (fmt "~a.tmp" name-try)))
(s name (with-open-file
(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)))) (stderr "going to rename in save-article-try~%")
(with-open-file ;; Because of my mess with directory paths, I'm having to do the
(s tmp ;; ../../ here. This is bad design. We need to find a solution
:direction :output ;; for this. But don't come up with the use
:if-exists :error ;; absolute-paths-solution. Relative paths is always better.
:if-does-not-exist :create (stderr "current-directory: ~a~%" (uiop:getcwd))
:element-type '(unsigned-byte 8)) (stderr "default-pathname: ~a~%" *default-pathname-defaults*)
(write-sequence bs s)) (stderr "rename-no-extension ~a ~a~%" (fmt "tmp/~a" src-path) (fmt "groups/local.test/~a" name))
(rename-no-extension tmp name))) (rename-no-extension (fmt "../../tmp/~a" src-path) name)))
(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)
(declare (ignore low len)) (declare (ignore low len))
(1+ high))) (1+ high)))
(defun nntp-read-article () (defun nntp-read-article-to-disk (tmp-path)
;; Returns a vector of bytes: the article, CRLF between lines, up to "Streams an article to disk."
;; (excluding) the "." terminator. VECTOR-PUSH-EXTEND grows the (let ((success nil))
;; buffer in amortized O(1) per push, so total cost is O(size of the (with-open-file (out tmp-path
;; article) rather than O([size of the article]^2). :direction :output
(let ((buf (make-array 8192
:element-type '(unsigned-byte 8) :element-type '(unsigned-byte 8)
:adjustable t :if-exists :error)
:fill-pointer 0))) (loop
(loop ;; 1. Fetch a clean line from your highly optimized buffer
(let ((ls (nntp-read-line))) (let ((line (nntp-read-line)))
(stderr "nntp-read-line: [~A]" ls) ;(stderr "read line: ~a~%" line)
(when (eq ls :eof) (error 'end-of-file :stream *standard-input*)) ;; 2. Detect terminator: A line containing exactly the byte 46 ('.')
(when (end-of-article? ls) (return buf)) (when (end-of-article? line)
(map nil (lambda (b) (vector-push-extend b buf)) ls) (setf success t)
(vector-push-extend 13 buf) (return tmp-path))
(vector-push-extend 10 buf))))) ;; 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 end-of-article? (ls) (defun end-of-article? (ls)
;; A line is the NNTP terminator only if it's exactly the single byte ;; A line is the NNTP terminator only if it's exactly the single byte
@ -1145,62 +1164,10 @@
(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))))
@ -1247,24 +1214,9 @@
"Peel away SYNONYM-STREAM and TWO-WAY-STREAM wrappers until we reach "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." the underlying FD-STREAM. Signals a clear error if no FD-STREAM is found."
(etypecase stream (etypecase stream
(sb-sys:fd-stream stream) (sb-sys:fd-stream stream)
(synonym-stream (fd-stream-of (symbol-value (synonym-stream-symbol stream)))) (synonym-stream (fd-stream-of (symbol-value (synonym-stream-symbol stream))))
(two-way-stream (fd-stream-of (two-way-stream-input-stream stream))))) (two-way-stream (fd-stream-of (two-way-stream-input-stream stream)))))
(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))
@ -1273,43 +1225,12 @@
(mapcar #'data->bytes (coerce v 'list))) (mapcar #'data->bytes (coerce v 'list)))
(defun data->bytes (d) (defun data->bytes (d)
(cond ((null d) nil) (etypecase d
((integerp d) (list d)) (null nil)
((stringp d) (string->bytes d)) (integer (list d))
((consp d) (list->bytes d)) (string (string->bytes d))
((vectorp d) (vector->bytes d)) (cons (list->bytes d))
(t (error (format nil "type ~a is not supported" (type-of d)))))) (vector (vector->bytes d))))
(defun send-chunk! (chunk s)
"Writes chunks sequentially to the stream."
(cond ((stringp chunk)
(my-write (string->bytes chunk) s))
((vectorp chunk)
(my-write chunk s))
((listp chunk)
(dolist (c chunk)
(send-chunk! c s)))
((integerp chunk)
(write-byte chunk s))
((file-stream-payload-p chunk)
(stream-file-to-socket chunk s))))
(defun stream-file-to-socket (payload out-stream)
"Opens the file, seeks to the start of the body, and streams to the socket
while applying on-the-fly NNTP dot-stuffing."
(with-open-file (in (file-stream-payload-path payload)
:element-type '(unsigned-byte 8))
(file-position in (file-stream-payload-start-pos payload))
(let ((buf (make-array 8192 :element-type '(unsigned-byte 8)))
(at-line-start t)) ; The body implicitly starts at the beginning of a line
(loop for n = (read-sequence buf in)
while (plusp n)
do (loop for i from 0 below n
for byte = (aref buf i)
do (when (and at-line-start (= byte 46)) ; 46 is '.'
(write-byte 46 out-stream))
(write-byte byte out-stream)
(setf at-line-start (= byte 10))))))) ; 10 is LF (\n)
(defun add-crlf-between (ls-of-ls) (defun add-crlf-between (ls-of-ls)
;; Add \r\n to each ``line''. Returns List-of Byte. ;; Add \r\n to each ``line''. Returns List-of Byte.
@ -1328,21 +1249,21 @@
(group-name-conforms? g) (group-name-conforms? g)
(if (not okay?) (if (not okay?)
(make-response :code 580 :request r (make-response :code 580 :request r
:data (format nil "group name does not conform: ~a" reason)) :data (fmt "group name does not conform: ~a" reason))
(progn (progn
(multiple-value-bind (path created?) (multiple-value-bind (path created?)
(in-groups (ensure-directories-exist (concatenate 'string g "/"))) (in-groups (ensure-directories-exist (concatenate 'string g "/")))
(declare (ignore created?)) (declare (ignore created?))
(if (not path) (if (not path)
(make-response :code 581 :request r (make-response :code 581 :request r
:data (format nil "could not create group ~a" :data (fmt "could not create group ~a"
(if (group? g) (if (group? g)
"because it already exists" "because it already exists"
"but we don't know why---sorry!"))) "but we don't know why---sorry!")))
(progn (progn
(notify-group-created g) (notify-group-created g)
(make-response :code 280 :request r (make-response :code 280 :request r
:data (format nil "group ~a created" g))))))))))) :data (fmt "group ~a created" g)))))))))))
(defun group-name-conforms? (g) (defun group-name-conforms? (g)
(conforms-to? g "^[^\\s/]+$")) (conforms-to? g "^[^\\s/]+$"))
@ -1400,23 +1321,46 @@
(write-accounts!) (write-accounts!)
(values (str:upcase username) p)))))) (values (str:upcase username) p))))))
(defmacro with-file-lock ((lock-path &key (sleep-time 0.1) (retries 50)) &body body)
(let ((lock-file (gensym "LOCK-FILE-"))
(stream (gensym "STREAM-"))
(attempt (gensym "ATTEMPT-")))
`(let ((,lock-file ,lock-path))
(unwind-protect
(progn
(loop for ,attempt from 1 to ,retries
do (handler-case
(with-open-file (,stream ,lock-file
:direction :output
:if-exists :error
:if-does-not-exist :create)
(format ,stream "~a~%" (get-universal-time))
(return))
(file-error ()
(if (= ,attempt ,retries)
(error "could not acquire lock on ~a after ~a attempts."
,lock-file ,retries)
(sleep ,sleep-time)))))
,@body)
(ignore-errors (delete-file ,lock-file))))))
(defun write-accounts! () (defun write-accounts! ()
(let ((name (with-file-lock ("accounts.lck")
(loop (let ((name
(loop
(let* ((tmp (random-string 10)) (let* ((tmp (random-string 10))
(name (format nil "~a.tmp" tmp))) (name (fmt "~a.tmp" tmp)))
(when (when (ignore-errors
(ignore-errors (with-open-file (s name
(with-open-file :direction :output
(s name :if-exists :error
:direction :output :if-does-not-exist :create)
:if-exists :error (write *accounts* :stream s)
:if-does-not-exist :create) t))
(write *accounts* :stream s)))
(return name)))))) (return name))))))
(if (ignore-errors (rename-file name "accounts.lisp")) (if (ignore-errors (rename-file name "accounts.lisp"))
(values t *accounts*) (values t *accounts*)
(values nil (format nil "could not rename ~a to accounts.lisp" name))))) (values nil (fmt "could not rename ~a to accounts.lisp" name))))))
(defun get-account (username) (defun get-account (username)
(loop for u in *accounts* (loop for u in *accounts*
@ -1551,7 +1495,7 @@
(if s (universal-to-human s)))))) (if s (universal-to-human s))))))
(defun cmd-dd (r) (defun cmd-dd (r)
(make-response :code 200 :data (format nil "state: ~a" *client*) :request r)) (make-response :code 200 :data (fmt "state: ~a" *client*) :request r))
(defun cmd-repl (r) (defun cmd-repl (r)
(if *enable-nntp-repl* (if *enable-nntp-repl*
@ -1581,19 +1525,29 @@
(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 (fmt "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 (fmt "From: Loop"))
(wline (fmt "Subject: ~a" subject))
(wline (fmt "Newsgroups: local.control.news"))
(wline (fmt "Message-ID: ~a" mid))
(wline (fmt "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))))))
(defun cli/options () (defun cli/options ()
(list (list

755
loop.nw
View file

File diff suppressed because it is too large Load diff