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

A major rewrite: new cmd-post, the index and procedure group-high-low.

Browse source 
The index is now a central part of the system, as it should.  We store
articles just like git stores its objects, in a two-tier directory.
For example, article whose message id hashes to deadbeef is stored at
index/de/ad/deadbeef.  Articles in groups are now hardlinked to the
index, the main repository of articles.

Group's article names are now cached in groups/<g>/.meta/.  The meta
information is incrementally augmented every time it's necessary.
Commands LIST and GROUP are now served at constant time.

Other little fixes were done a long the way.
This commit is contained in:
Circling Skies 2026-08-13 13:12:47 -03:00
parent 602f44b464
commit 05be4aad57
8 changed files with 774 additions and 645 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Makefile
View file

@ -4,6 +4,6 @@ loop: loop.asd loop.lisp scripts/build-exe.lisp
sbcl --script scripts/build-exe.lisp sbcl --script scripts/build-exe.lisp
install: loop install: loop
mkdir -p `head -1 conf-home`/tmp && \ mkdir -p `head -1 conf-home` && \
cp -R loop accounts.lisp groups scripts \ cp -R loop accounts.lisp groups scripts \
`head -1 conf-home` `head -1 conf-home`

392
loop.lisp
View file

@ -24,7 +24,6 @@
(defparameter *client* (make-client)) (defparameter *client* (make-client))
(defstruct request verb args said) (defstruct request verb args said)
(defstruct response code data request multi-line) (defstruct response code data request multi-line)
(defstruct command fn verb description) (defstruct command fn verb description)
(defparameter *commands-assoc* nil) (defparameter *commands-assoc* nil)
(defstruct article head body) (defstruct article head body)
@ -92,6 +91,29 @@
:description "a command for all commands typed wrongly"))) :description "a command for all commands typed wrongly")))
(or (cdr cmd) (unrecognized-command))))) (or (cdr cmd) (unrecognized-command)))))
(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))))))
(defmacro in-dir (dir &rest body) (defmacro in-dir (dir &rest body)
`(let ((*default-pathname-defaults* (truename ,dir))) `(let ((*default-pathname-defaults* (truename ,dir)))
(uiop:with-current-directory (,dir) (uiop:with-current-directory (,dir)
@ -237,32 +259,6 @@
:verb (str:upcase verb) :verb (str:upcase verb)
:args args)))))) :args args))))))
(defun insert-index (m g i)
(handler-case
(clsql:insert-records
:into "indices"
:attributes '(id grp article)
:values (list (str:trim m) (str:trim g) (str:trim i)))
(clsql-sys:sql-database-data-error (c)
(cond ((= (slot-value c 'clsql-sys::error-id) 19)
'already-indexed)
(t
; We should log this error.
;(format t "other error: ~a" (slot-value c 'clsql-sys::database-message))
'sql-error)))
(:no-error ()
nil)))
(defun lookup-index (mid)
(let* ((found (clsql:select [grp] [article]
:from [indices]
:where [= [id] (str:trim mid)]))
(article (first found))
(grp (first article))
(art (second article)))
(when found
(values grp art))))
(defun remove-inactive-users! () (defun remove-inactive-users! ()
(loop for u in *accounts* do (loop for u in *accounts* do
(let ((username (account-username u))) (let ((username (account-username u)))
@ -363,25 +359,6 @@
(setf (account-last-post u) (account-seen u)))) (setf (account-last-post u) (account-seen u))))
(write-accounts!)) (write-accounts!))
(defun split-vector (delim v acc &key limit (so-far 1))
(let ((len (length v)))
(split-vector-helper delim v len acc limit so-far 0)))
(defun split-vector-helper (delim v len acc limit so-far start)
(if (zerop len)
acc
(let ((pos (search delim v :start2 start :end2 len)))
(cond ((or (not pos) (and limit (= so-far limit)))
(nreverse (cons (subseq v start len) acc)))
(t (split-vector-helper
delim
v
len
(cons (subseq v start (or pos len)) acc)
limit
(1+ so-far)
(+ pos (length delim))))))))
(defun index-from-fs! () (defun index-from-fs! ()
(loop for path in (in-groups (directory "**/*")) (loop for path in (in-groups (directory "**/*"))
do (let* ((g (str:trim (first (last (pathname-directory path))))) do (let* ((g (str:trim (first (last (pathname-directory path)))))
@ -395,6 +372,27 @@
(drop-create-index!) (drop-create-index!)
(index-from-fs!)) (index-from-fs!))
(defun read-headers-raw (path)
(with-open-file (in path :element-type '(unsigned-byte 8) :if-does-not-exist :error)
(let ((acc (make-array 8192
:element-type '(unsigned-byte 8)
:adjustable t :fill-pointer 0))
(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))))))))))
(defun parse-article (v) (defun parse-article (v)
(let ((pos (search #(13 10 13 10) v))) (let ((pos (search #(13 10 13 10) v)))
(if pos (if pos
@ -464,36 +462,15 @@
(in-group g (in-group g
(read-headers-raw (fmt "~a" i)))) (read-headers-raw (fmt "~a" i))))
(defun read-headers-raw (path)
(with-open-file (in path :element-type '(unsigned-byte 8) :if-does-not-exist :error)
(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)))
(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 stream-file-to-socket (payload out-stream) (defun stream-file-to-socket (payload out-stream)
"Opens the file, seeks to the start of the body, and streams to the socket "Opens the file, seeks to the start of the body, and streams to the socket
while applying on-the-fly NNTP dot-stuffing." while applying on-the-fly NNTP dot-stuffing."
(with-open-file (in (file-stream-payload-path payload) (with-open-file (in (file-stream-payload-path payload)
:element-type '(unsigned-byte 8)) :element-type '(unsigned-byte 8))
;; file-position here is doing what ftell(3) in C would do
(file-position in (file-stream-payload-start-pos payload)) (file-position in (file-stream-payload-start-pos payload))
(let ((buf (make-array 8192 :element-type '(unsigned-byte 8))) (let ((buf (make-array 8192 :element-type '(unsigned-byte 8)))
(at-line-start t)) ; The body implicitly starts at the beginning of a line (at-line-start t))
(loop for n = (read-sequence buf in) (loop for n = (read-sequence buf in)
while (plusp n) while (plusp n)
do (loop for i from 0 below n do (loop for i from 0 below n
@ -522,6 +499,57 @@
(force-output) (force-output)
r) r)
(defun index-hash (mid)
(ironclad:byte-array-to-hex-string (string->sha256 (str:trim mid))))
(defun index-fanout (hash)
(values (subseq hash 0 2) (subseq hash 2 4)))
(defun index-path-dir (hash)
(multiple-value-bind (b1 b2) (index-fanout hash)
(fmt "index/~a/~a/" b1 b2)))
(defun index-path (hash)
(fmt "~a~a" (index-path-dir hash) hash))
(defun ensure-index-directories! (hash)
(ensure-directories-exist (index-path-dir hash)))
(defun get-mid-from-path (path)
(get-header "message-id"
(parse-headers (bytes->string (read-headers-raw path)))))
(define-condition already-seen-article (error)
((mid :initarg :mid
:initform nil
:reader already-seen-article-mid))
(:report (lambda (condition stream)
(format stream "Message-id ~a has already been seen."
(already-seen-article-mid condition)))))
(defun store-article-in-index! (tmp-path mid)
(let* ((hash (index-hash mid))
(path-id (index-path hash)))
(ensure-index-directories! hash)
(if (not (probe-file path-id))
(rename-no-extension tmp-path path-id)
(error 'already-seen-article :mid mid))
hash))
(defun link-article-into-group-insist! (hash ng name)
(loop for c from name
do (let ((result (link-article-into-group! hash ng c)))
(unless (eq result :name-exists)
(return (values result t))))))
(defun link-article-into-group! (hash g name)
(handler-case
(progn (sb-posix:link (index-path hash) (fmt "groups/~a/~a" g name))
name)
(sb-posix:syscall-error (c)
(if (= (sb-posix:syscall-errno c) sb-posix:eexist)
:name-exists
(error c)))))
(defun dispatch (r) (defun dispatch (r)
(let* ((verb (request-verb r))) (let* ((verb (request-verb r)))
(if (null verb) (if (null verb)
@ -609,19 +637,20 @@
(if (null headers-raw) (if (null headers-raw)
(make-response :code 400 :request r :data (fmt "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
(mid (extract-mid headers-raw)) (mid (extract-mid headers-raw))
(header-length (length headers-raw)) (head-length (length headers-raw))
(body-start (+ head-length 4)) ;; 4 bytes due to \r\n\r\n
(payload (payload
(ecase requested-part (ecase requested-part
(:head (article-head 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 body-start))
(:article (list (article-head a) (:article (list (article-head a)
(crlf) (crlf) (crlf)
(crlf) (make-file-stream-payload :path path
(make-file-stream-payload :path path :start-pos header-length)))))) :start-pos body-start))))))
(prepend-response-with (fmt "~a ~a" i mid) (prepend-response-with (fmt "~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 (fmt "article ~a/~a: ~a" g i c))) (let ((msg (fmt "article ~a/~a: ~a" g i c)))
@ -758,11 +787,12 @@
(or (zero-file? path) (or (zero-file? path)
(cl-ppcre:scan "\.tmp$" (namestring path)))) (cl-ppcre:scan "\.tmp$" (namestring path))))
(defun article-ready? (path) (defun article-ready?-old (path)
(not (temporary-article? path))) (not (temporary-article? path)))
(defun loop-directory* (directory &rest args &key &allow-other-keys) (defun loop-directory* (directory &rest args &key &allow-other-keys)
#+allegro (apply #'directory directory :directories-are-files NIL :follow-symbolic-links NIL args) #+allegro (apply #'directory directory :directories-are-files NIL
:follow-symbolic-links NIL args)
#+(or clozure digitool) (apply #'directory directory :follow-links NIL args) #+(or clozure digitool) (apply #'directory directory :follow-links NIL args)
#+clisp (apply #'directory directory :circle T :if-does-not-exist :ignore args) #+clisp (apply #'directory directory :circle T :if-does-not-exist :ignore args)
#+(or cmucl scl) (apply #'directory directory :follow-links NIL :truenamep NIL args) #+(or cmucl scl) (apply #'directory directory :follow-links NIL :truenamep NIL args)
@ -802,22 +832,73 @@
collect (pathname-utils:force-directory path))))) collect (pathname-utils:force-directory path)))))
(defun get-articles (g &optional from to) (defun get-articles (g &optional from to)
(in-groups ;; We might want to optimize this some day. That's a (in-groups ;; It's okay for this to be slow because we only run this
;; problem to be studied. ;; one time in the birth of a group.
(let ((as (articles->integers (let ((as (articles->integers (loop-list-files (truename g)))))
(remove-if #'temporary-article? (loop-list-files (truename g))))))
(sort (remove-if-not (sort (remove-if-not
#'(lambda (x) (between? x (or from x) (or to x))) #'(lambda (x) (between? x (or from x) (or to x)))
as) as)
#'<)))) #'<))))
(defun group-high-low (g) (defun group-high-low-fallback (g)
(let* ((articles (get-articles g)) (let* ((articles (get-articles g))
(sorted-ints (sort articles #'<))) (sorted-ints (sort articles #'<)))
(values (or (car sorted-ints) 0) (values (or (car sorted-ints) 0)
(or (car (last sorted-ints)) 0) (or (car (last sorted-ints)) 0)
(length sorted-ints)))) (length sorted-ints))))
(defun update-group-meta-absolute! (g low high count)
"Atomically overwrites the meta file from scratch."
(let* ((meta-path (fmt "groups/~a/.meta/low-high-count" g))
(lock-path (fmt "~a.lck" meta-path))
(tmp-path (fmt "~a.tmp" meta-path)))
(ensure-directories-exist meta-path)
(with-file-lock (lock-path)
(with-open-file (out tmp-path :direction :output
:if-exists :supersede
:if-does-not-exist :create)
(format out "~a ~a ~a~%" low high count))
(rename-no-extension tmp-path meta-path))))
(defun update-group-meta-incremental! (g article-id)
"Atomically updates metadata when a new article is posted."
(let* ((meta-path (fmt "groups/~a/.meta/low-high-count" g))
(lock-path (fmt "~a.lck" meta-path))
(tmp-path (fmt "~a.tmp" meta-path)))
(ensure-directories-exist meta-path)
(with-file-lock (lock-path)
(multiple-value-bind (low high count) (read-low-high-count meta-path)
(with-open-file (out tmp-path :direction :output
:if-exists :supersede
:if-does-not-exist :create)
(format out "~a ~a ~a~%"
(if (zerop low) article-id low) ;; New Low
(max high article-id) ;; New High
(1+ count))) ;; New Count
(rename-no-extension tmp-path meta-path)))))
(defun read-low-high-count (meta-path)
"Reads (low high count), returning (0 0 0) if the file doesn't exist."
(with-open-file (in meta-path :direction :input :if-does-not-exist nil)
(if in
(values (read in nil 0)
(read in nil 0)
(read in nil 0))
(values 0 0 0))))
(defun group-high-low (g)
"Constant-time retrieval of group boundaries."
(ensure-directories-exist (fmt "groups/~a/.meta/" g))
(let ((meta-path (fmt "groups/~a/.meta/low-high-count" g)))
(if (probe-file meta-path)
(read-low-high-count meta-path)
;; Well, .meta/low-high-count doesn't exist, this is the first
;; time we're running, so let's compute the numbers for a
;; first time.
(multiple-value-bind (low high count) (group-high-low-fallback g)
(update-group-meta-absolute! g low high count)
(values low high count)))))
(defun articles->integers (ls) (defun articles->integers (ls)
(remove-if #'null (remove-if #'null
(mapcar #'(lambda (g) (mapcar #'(lambda (g)
@ -857,11 +938,21 @@
(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))
(defun nntp-date-header ()
"An RFC 1123 compliant date for use in article headers."
(format-timestring nil (now) :format +rfc-1123-format+ :timezone +utc-zone+))
(defun nntp-date-command ()
"Generates the yyyymmddhhmmss UTC string for the NNTP DATE command."
(format-timestring nil (now)
:format '(:year (:month 2) (:day 2) (:hour 2) (:min 2) (:sec 2))
:timezone +utc-zone+))
(defun cmd-date (r) (defun cmd-date (r)
(make-response :code 201 (make-response :code 201
:request r :request r
:data :data
(format-timestring nil (now)))) (nntp-date-command)))
(defun conforms? (bs) (defun conforms? (bs)
(catch 'article-syntax-error (catch 'article-syntax-error
@ -923,16 +1014,18 @@
(make-response (make-response
:code 340 :code 340
:data (fmt "Okay, go ahead. Suggested message-id ~a." suggested))) :data (fmt "Okay, go ahead. Suggested message-id ~a." suggested)))
(let ((tmp (fmt "post-~a.tmp" (random-string 12)))) (let ((tmp (fmt "tmp/post-~a.tmp" (random-string 12))))
(unwind-protect (unwind-protect
(progn (progn
(in-tmp (nntp-read-article-to-disk tmp)) (nntp-read-article-to-disk tmp)
(stderr "finished writing article to disk in tmp/~a~%" tmp) (stderr "finished writing article to disk in tmp/~a~%" tmp)
(let* ((headers-raw (in-tmp (read-headers-raw tmp))) (let* ((headers-raw (read-headers-raw tmp))
;; headers-raw includes the terminating CRLF CRLF; strip it ;; headers-raw includes the terminating CRLF CRLF; strip it
;; so parse-headers does not see an empty final line. ;; so parse-headers does not see an empty final line.
(headers-str (map 'string #'code-char (headers-str (bytes->string headers-raw))
(subseq headers-raw 0 (max 0 (- (length headers-raw) 4)))))) (hds (parse-headers headers-str))
(mid (get-header "message-id" hds))
(ngs (newsgroups-header->list (get-header "newsgroups" hds))))
(stderr "finished reading the headers of the tmp file~%") (stderr "finished reading the headers of the tmp file~%")
(stderr "headers string: ~a~%" headers-str) (stderr "headers string: ~a~%" headers-str)
(multiple-value-bind (okay? error) (conforms-headers? headers-str) (multiple-value-bind (okay? error) (conforms-headers? headers-str)
@ -942,32 +1035,18 @@
:code 400 :request r :code 400 :request r
:data (fmt "Sorry. Your article doesn't conform: ~a." error))) :data (fmt "Sorry. Your article doesn't conform: ~a." error)))
(t (t
(multiple-value-bind (code reply) (handler-case
(post tmp headers-raw) (let* ((hash (store-article-in-index! tmp mid)))
(stderr "I'd post this article now.~%") (stderr "stored ~a from ~a~%" hash mid)
(update-last-post-date! (client-username *client*))
(make-response :code code :request r :data reply)))))))
(ignore-errors (delete-file tmp)))))))
(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) (dolist (ng ngs)
(save-article-insist ng (get-next-article-id ng) tmp-path)) (let ((new-id (link-article-into-group-insist! hash ng (get-next-article-id ng))))
(values 240 "Thank you! Your article has been saved."))) (update-group-meta-incremental! ng new-id)))
(stderr "Procedure post has finished.~%")
(update-last-post-date! (client-username *client*))
(make-response :code 240 :request r :data "Thank you! Your article has been saved."))
(already-seen-article (c)
(make-response :code 441 :request r :data (fmt "~a" c)))))))))
(ignore-errors (delete-file tmp)))))))
(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)))
@ -980,8 +1059,8 @@
(rename-file (merge-pathnames old (uiop:getcwd)) (rename-file (merge-pathnames old (uiop:getcwd))
(merge-pathnames (make-pathname :name new :type :unspecific) (uiop:getcwd)))) (merge-pathnames (make-pathname :name new :type :unspecific) (uiop:getcwd))))
(defun save-article-try (name-try src-path) (defun save-article-try-old (g name-try tmp-path)
(stderr "going to try to save ~a with name ~a~%" src-path name-try) (stderr "going to try to save ~a with name ~a/~a~%" tmp-path g name-try)
(let ((name (fmt "~a" name-try)) (let ((name (fmt "~a" name-try))
(tmp (fmt "~a.tmp" name-try))) (tmp (fmt "~a.tmp" name-try)))
(with-open-file (with-open-file
@ -991,22 +1070,33 @@
:if-does-not-exist :create) :if-does-not-exist :create)
(when (null s) (when (null s)
(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-old 'name-exists)))
(stderr "going to rename in save-article-try~%") (stderr "going to rename in save-article-try~%")
;; Because of my mess with directory paths, I'm having to do the ;; We've been called to save tmp-path to its permanent name. We're
;; ../../ here. This is bad design. We need to find a solution ;; merely going to rename it there. So the rename call is now
;; for this. But don't come up with the use ;; tmp/post-tmpfile.tmp to index/bb/bb/hash. To get the hash we
;; absolute-paths-solution. Relative paths is always better. ;; need need the message-id.
(stderr "current-directory: ~a~%" (uiop:getcwd)) (stderr "current-directory: ~a~%" (uiop:getcwd))
(stderr "default-pathname: ~a~%" *default-pathname-defaults*) (stderr "default-pathname: ~a~%" *default-pathname-defaults*)
(stderr "rename-no-extension ~a ~a~%" (fmt "tmp/~a" src-path) (fmt "groups/local.test/~a" name)) ;(stderr "rename-no-extension ~a ~a~%" (fmt "~a" tmp-path) (fmt "~a" name))
(rename-no-extension (fmt "../../tmp/~a" src-path) name)))
(defun save-article-insist (g name src-path) ;; The call to rename-no-extension must be at the root, so I can't
;; localize my life using in-group or in-groups here. Leaving it
;; like that.
;;(rename-no-extension (fmt "~a" tmp-path) (fmt "groups/~a/~a" g name))
;; We don't call rename here any longer. The article is now
;; safely written to tmp and it's time to store it at its
;; permanent path, which is computed by store-article-in-index!
;; So go ahead and do that. But we need the MID now! Delegated
;; it to the index itself. (Notice we don't need G here anymore.)
(store-article-in-index! tmp-path)))
(defun save-article-insist-old (g name src-path)
(loop for name from name do (loop for name from name do
(in-group g (when (not (eql 'name-exists (save-article-try-old g name src-path)))
(when (not (eql 'name-exists (save-article-try name src-path))) (return (values name t)))))
(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)
@ -1015,24 +1105,19 @@
(defun nntp-read-article-to-disk (tmp-path) (defun nntp-read-article-to-disk (tmp-path)
"Streams an article to disk." "Streams an article to disk."
(let ((success nil)) (ensure-directories-exist "tmp/")
(with-open-file (out tmp-path (with-open-file (out tmp-path
:direction :output :direction :output
:element-type '(unsigned-byte 8) :element-type '(unsigned-byte 8)
:if-exists :error) :if-exists :error)
(loop (loop
;; 1. Fetch a clean line from your highly optimized buffer
(let ((line (nntp-read-line))) (let ((line (nntp-read-line)))
;; 2. Detect terminator: A line containing exactly the byte 46 ('.')
(when (end-of-article? line) (when (end-of-article? line)
(setf success t)
(return tmp-path)) (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))) (let ((start-idx (if (and (> (length line) 0) (= (aref line 0) 46)) 1 0)))
(write-sequence line out :start start-idx))) (write-sequence line out :start start-idx)))
;; 4. Restore the CRLF that `nntp-read-line` stripped away
(write-byte 13 out) (write-byte 13 out)
(write-byte 10 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
@ -1242,29 +1327,6 @@
(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! ()
(with-file-lock ("accounts.lck") (with-file-lock ("accounts.lck")
(let ((name (let ((name
@ -1345,7 +1407,8 @@
(multiple-value-bind (cur new) (apply #'values args) (multiple-value-bind (cur new) (apply #'values args)
(cond (cond
((pass? (client-username *client*) cur) ((pass? (client-username *client*) cur)
(multiple-value-bind (okay? problem) (change-passwd! (client-username *client*) new) (multiple-value-bind (okay? problem)
(change-passwd! (client-username *client*) new)
(if okay? (if okay?
(make-response :code 200 :request r (make-response :code 200 :request r
:data "You got it. Password changed.") :data "You got it. Password changed.")
@ -1446,11 +1509,11 @@
(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") (let ((tmp (fmt "tmp/notify-~a.tmp" (random-string 10)))
(let ((tmp (fmt "notify-~a.tmp" (random-string 10)))
(mid (suggest-message-id))) (mid (suggest-message-id)))
(unwind-protect (unwind-protect
(progn (progn
;; XXX: abstract this away into its own procedure.
(with-open-file (out tmp (with-open-file (out tmp
:direction :output :direction :output
:element-type '(unsigned-byte 8) :element-type '(unsigned-byte 8)
@ -1463,13 +1526,13 @@
(wline (fmt "Subject: ~a" subject)) (wline (fmt "Subject: ~a" subject))
(wline (fmt "Newsgroups: local.control.news")) (wline (fmt "Newsgroups: local.control.news"))
(wline (fmt "Message-ID: ~a" mid)) (wline (fmt "Message-ID: ~a" mid))
(wline (fmt "Date: ~a" (get-date))) (wline (fmt "Date: ~a" (nntp-date-header)))
(write-byte 13 out) (write-byte 10 out) (write-byte 13 out) (write-byte 10 out)
(write-sequence (map 'vector #'char-code body) out) (write-sequence (map 'vector #'char-code body) out)
(write-byte 13 out) (write-byte 10 out))) (write-byte 13 out) (write-byte 10 out)))
(let ((headers-raw (read-headers-raw tmp))) (let ((headers-raw (read-headers-raw tmp)))
(post tmp headers-raw))) (post tmp headers-raw)))
(ignore-errors (delete-file tmp)))))) (ignore-errors (delete-file tmp)))))
(defun cli/options () (defun cli/options ()
(list (list
@ -1531,7 +1594,8 @@
(new-passwd (or given-passwd random-passwd))) (new-passwd (or given-passwd random-passwd)))
(if (not (get-account username)) (if (not (get-account username))
(println "No such account ``~a''." username) (println "No such account ``~a''." username)
(multiple-value-bind (okay? problem) (change-passwd! username new-passwd) (multiple-value-bind (okay? problem)
(change-passwd! username new-passwd)
(if okay? (if okay?
(println "Okay, account ~a now has password ``~a''." username new-passwd) (println "Okay, account ~a now has password ``~a''." username new-passwd)
(println "Sorry, could not change password: ~a." problem)))))) (println "Sorry, could not change password: ~a." problem))))))
@ -1586,7 +1650,7 @@
(loop (loop
(let* ((bs (nntp-read-line)) (let* ((bs (nntp-read-line))
(ln (bytes->string bs))) (ln (bytes->string bs)))
(stderr "<<< ~a~%" ln) ;; for logging (stderr "<<< ~a~%" ln)
(let ((r (send-response! (dispatch-line ln)))) (let ((r (send-response! (dispatch-line ln))))
(when (response-quit? r) (when (response-quit? r)
(return))))) (return)))))

880
loop.nw
View file

File diff suppressed because it is too large Load diff

2
scripts/build-index-from-fs.lisp
View file

@ -5,7 +5,5 @@
(load quicklisp-init))) (load quicklisp-init)))
(ql:quickload :loop :silent t) (ql:quickload :loop :silent t)
(in-package #:loop) (in-package #:loop)
(connect-index! "message-id.db")
(drop-create-index!)
(index-from-fs!) (index-from-fs!)
(format t "Index built.~%") (format t "Index built.~%")

1
scripts/cron-remove-inactive-users.lisp
View file

@ -6,6 +6,5 @@
(ql:quickload :loop :silent t) (ql:quickload :loop :silent t)
(in-package #:loop) (in-package #:loop)
(read-accounts!) (read-accounts!)
(connect-index! "message-id.db")
(remove-inactive-users!) (remove-inactive-users!)
(write-accounts!) (write-accounts!)

2
version.lisp
View file

@ -1,2 +1,2 @@
(in-package :loop) (in-package :loop)
(defparameter *git-hash* "9f48666") (defparameter *git-hash* "d44771c")