diff --git a/Makefile b/Makefile index 248657c..7b81a2e 100644 --- a/Makefile +++ b/Makefile @@ -4,6 +4,6 @@ loop: loop.asd loop.lisp scripts/build-exe.lisp sbcl --script scripts/build-exe.lisp install: loop - mkdir -p `head -1 conf-home`/tmp && \ + mkdir -p `head -1 conf-home` && \ cp -R loop accounts.lisp groups scripts \ `head -1 conf-home` diff --git a/groups/local.control.news/1 b/groups/local.control.news/1 index 81d2d97..adc869e 100644 --- a/groups/local.control.news/1 +++ b/groups/local.control.news/1 @@ -1,7 +1,7 @@ -Date: 2024-03-07 21:44:31 GMT-3 -Message-Id: -From: Loop -Subject: let there be light -Newsgroups: local.control.news - -Administrative news will be posted here by me. -- Loop +Date: 2024-03-07 21:44:31 GMT-3 +Message-Id: +From: Loop +Subject: let there be light +Newsgroups: local.control.news + +Administrative news will be posted here by me. -- Loop diff --git a/groups/local.test/1 b/groups/local.test/1 index ae3d03f..3aaf4f9 100644 --- a/groups/local.test/1 +++ b/groups/local.test/1 @@ -1,7 +1,7 @@ -Date: 2024-03-07 21:44:31 GMT-3 -Message-Id: -From: Loop -Subject: let there be light -Newsgroups: local.test - -A sample group. +Date: 2024-03-07 21:44:31 GMT-3 +Message-Id: +From: Loop +Subject: let there be light +Newsgroups: local.test + +A sample group. diff --git a/loop.lisp b/loop.lisp index da34bc4..c8319b5 100644 --- a/loop.lisp +++ b/loop.lisp @@ -24,7 +24,6 @@ (defparameter *client* (make-client)) (defstruct request verb args said) (defstruct response code data request multi-line) - (defstruct command fn verb description) (defparameter *commands-assoc* nil) (defstruct article head body) @@ -92,6 +91,29 @@ :description "a command for all commands typed wrongly"))) (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) `(let ((*default-pathname-defaults* (truename ,dir))) (uiop:with-current-directory (,dir) @@ -237,32 +259,6 @@ :verb (str:upcase verb) :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! () (loop for u in *accounts* do (let ((username (account-username u))) @@ -363,25 +359,6 @@ (setf (account-last-post u) (account-seen u)))) (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! () (loop for path in (in-groups (directory "**/*")) do (let* ((g (str:trim (first (last (pathname-directory path))))) @@ -395,20 +372,41 @@ (drop-create-index!) (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) (let ((pos (search #(13 10 13 10) v))) (if pos - (make-article + (make-article :head (map 'string #'code-char (subseq v 0 pos)) :body (make-array (- (length v) (+ pos 4)) :element-type (array-element-type v) :displaced-to v :displaced-index-offset (+ pos 4))) - (make-article + (make-article :head (map 'string #'code-char 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 (fmt "~a[ ~a]+" (crlf-string) #\tab) hs " ")) (defun hs-lines (lines) (str:split (crlf-string) lines)) @@ -417,12 +415,12 @@ (let* ((h (str:collapse-whitespaces header)) (pos (search ":" h))) (when (null pos) - (throw 'article-syntax-error + (throw 'article-syntax-error (values nil (fmt "missing colon in header |~a|" h)))) (when (<= (length h) (+ 2 pos)) (throw 'article-syntax-error (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))) (cons (str:downcase key) val)))) @@ -432,7 +430,7 @@ (defun string-integer? (s) (ignore-errors (parse-integer s))) -(defun get-header (key hs) +(defun get-header (key hs) (let ((pair (assoc key hs :test #'string=))) (if pair (cdr pair) ""))) @@ -447,7 +445,7 @@ `(("line-count" . ,(fmt "~a" (nlines (article-body a-parsed)))) ("byte-count" . ,(fmt "~a" (length a-raw)))))) -(defun nlines (v) +(defun nlines (v) (loop for b across v count (= b 10))) @@ -464,36 +462,15 @@ (in-group g (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) "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 here is doing what ftell(3) in C would do (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 + (at-line-start t)) (loop for n = (read-sequence buf in) while (plusp n) do (loop for i from 0 below n @@ -522,6 +499,57 @@ (force-output) 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) (let* ((verb (request-verb r))) (if (null verb) @@ -609,19 +637,20 @@ (if (null headers-raw) (make-response :code 400 :request r :data (fmt "article ~a/~a does not exist" g i)) (let* ((a (parse-article headers-raw)) - ;; FIX: Pass the raw bytes to extract-mid, not the parsed struct (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 (ecase requested-part (: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) - (crlf) - (crlf) - (make-file-stream-payload :path path :start-pos header-length)))))) + (crlf) (crlf) + (make-file-stream-payload :path path + :start-pos body-start)))))) (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) (let ((msg (fmt "article ~a/~a: ~a" g i c))) @@ -758,11 +787,12 @@ (or (zero-file? path) (cl-ppcre:scan "\.tmp$" (namestring path)))) -(defun article-ready? (path) +(defun article-ready?-old (path) (not (temporary-article? path))) (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) #+clisp (apply #'directory directory :circle T :if-does-not-exist :ignore args) #+(or cmucl scl) (apply #'directory directory :follow-links NIL :truenamep NIL args) @@ -802,22 +832,73 @@ collect (pathname-utils:force-directory path))))) (defun get-articles (g &optional from to) - (in-groups ;; We might want to optimize this some day. That's a - ;; problem to be studied. - (let ((as (articles->integers - (remove-if #'temporary-article? (loop-list-files (truename g)))))) + (in-groups ;; It's okay for this to be slow because we only run this + ;; one time in the birth of a group. + (let ((as (articles->integers (loop-list-files (truename g))))) (sort (remove-if-not #'(lambda (x) (between? x (or from x) (or to x))) as) #'<)))) -(defun group-high-low (g) +(defun group-high-low-fallback (g) (let* ((articles (get-articles g)) (sorted-ints (sort articles #'<))) (values (or (car sorted-ints) 0) (or (car (last sorted-ints)) 0) (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) (remove-if #'null (mapcar #'(lambda (g) @@ -857,11 +938,21 @@ (defun cmd-quit (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) (make-response :code 201 :request r :data - (format-timestring nil (now)))) + (nntp-date-command))) (defun conforms? (bs) (catch 'article-syntax-error @@ -923,16 +1014,18 @@ (make-response :code 340 :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 (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) - (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 ;; 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)))))) + (headers-str (bytes->string headers-raw)) + (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 "headers string: ~a~%" headers-str) (multiple-value-bind (okay? error) (conforms-headers? headers-str) @@ -942,33 +1035,19 @@ :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))))))) + (handler-case + (let* ((hash (store-article-in-index! tmp mid))) + (stderr "stored ~a from ~a~%" hash mid) + (dolist (ng ngs) + (let ((new-id (link-article-into-group-insist! hash ng (get-next-article-id ng)))) + (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 post (tmp-path headers-raw) - (let* ((headers-str (map 'string #'code-char - (subseq headers-raw 0 (max 0 (- (length headers-raw) 4))))) - (headers (parse-headers headers-str)) - (ngs (newsgroups-header->list (get-header "newsgroups" headers))) - (body-start (length headers-raw))) - ;; This has gotten complicated. We need to move TMP-PATH into the - ;; first newsgroup and then symlink the article to all other - ;; groups. This means we give a different treatment to - ;; groups. This isn't so good. Looks like we should create a - ;; file-system index of articles and then symlink each article to - ;; each group---a more general treatment. Do this crazy thing now - ;; and then generalize only later once you've cleaned this code up - ;; so much. So here's your NEXT STEP: forget symlinks for now; - ;; copy the temporary article to each directory before you post - ;; it; IMPLEMENT COPY-TEMPORARY-FILE-TO and test the system. - (dolist (ng ngs) - (save-article-insist ng (get-next-article-id ng) tmp-path)) - (values 240 "Thank you! Your article has been saved."))) - (defun newsgroups-header->list (s) (mapcar #'(lambda (n) (str:trim (string-downcase n))) (str:split "," s))) @@ -980,8 +1059,8 @@ (rename-file (merge-pathnames old (uiop:getcwd)) (merge-pathnames (make-pathname :name new :type :unspecific) (uiop:getcwd)))) -(defun save-article-try (name-try src-path) - (stderr "going to try to save ~a with name ~a~%" src-path name-try) +(defun save-article-try-old (g name-try tmp-path) + (stderr "going to try to save ~a with name ~a/~a~%" tmp-path g name-try) (let ((name (fmt "~a" name-try)) (tmp (fmt "~a.tmp" name-try))) (with-open-file @@ -991,22 +1070,33 @@ :if-does-not-exist :create) (when (null s) (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~%") - ;; Because of my mess with directory paths, I'm having to do the - ;; ../../ here. This is bad design. We need to find a solution - ;; for this. But don't come up with the use - ;; absolute-paths-solution. Relative paths is always better. + ;; We've been called to save tmp-path to its permanent name. We're + ;; merely going to rename it there. So the rename call is now + ;; tmp/post-tmpfile.tmp to index/bb/bb/hash. To get the hash we + ;; need need the message-id. + (stderr "current-directory: ~a~%" (uiop:getcwd)) (stderr "default-pathname: ~a~%" *default-pathname-defaults*) - (stderr "rename-no-extension ~a ~a~%" (fmt "tmp/~a" src-path) (fmt "groups/local.test/~a" name)) - (rename-no-extension (fmt "../../tmp/~a" src-path) name))) + ;(stderr "rename-no-extension ~a ~a~%" (fmt "~a" tmp-path) (fmt "~a" 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 - (in-group g - (when (not (eql 'name-exists (save-article-try name src-path))) - (return (values name t)))))) + (when (not (eql 'name-exists (save-article-try-old g name src-path))) + (return (values name t))))) (defun get-next-article-id (g) (multiple-value-bind (low high len) (group-high-low g) @@ -1015,24 +1105,19 @@ (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))) - ;; 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))))) + (ensure-directories-exist "tmp/") + (with-open-file (out tmp-path + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :error) + (loop + (let ((line (nntp-read-line))) + (when (end-of-article? line) + (return tmp-path)) + (let ((start-idx (if (and (> (length line) 0) (= (aref line 0) 46)) 1 0))) + (write-sequence line out :start start-idx))) + (write-byte 13 out) + (write-byte 10 out)))) (defun end-of-article? (ls) ;; A line is the NNTP terminator only if it's exactly the single byte @@ -1242,29 +1327,6 @@ (write-accounts!) (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! () (with-file-lock ("accounts.lck") (let ((name @@ -1345,7 +1407,8 @@ (multiple-value-bind (cur new) (apply #'values args) (cond ((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? (make-response :code 200 :request r :data "You got it. Password changed.") @@ -1398,10 +1461,10 @@ (if (locked? (account-username u)) (fmt " (account locked: ~a)" (account-pass-locked-why u)) - "") + "") (if (last-time-seen (account-username u)) (fmt "last seen on ~a" (last-time-seen (account-username u))) - "never logged in") + "never logged in") (or (account-friends u) "nobody")))) #'string<= :key #'(lambda (row) (car row))))) @@ -1446,30 +1509,30 @@ (defun post-notification (&key subject body) (in-groups (ensure-directories-exist "local.control.news/")) - (when (group? "local.control.news") - (let ((tmp (fmt "notify-~a.tmp" (random-string 10))) - (mid (suggest-message-id))) - (unwind-protect - (progn - (with-open-file (out tmp - :direction :output - :element-type '(unsigned-byte 8) - :if-exists :supersede - :if-does-not-exist :create) - (flet ((wline (s) - (write-sequence (map 'vector #'char-code s) out) - (write-byte 13 out) (write-byte 10 out))) - (wline (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)))))) + (let ((tmp (fmt "tmp/notify-~a.tmp" (random-string 10))) + (mid (suggest-message-id))) + (unwind-protect + (progn + ;; XXX: abstract this away into its own procedure. + (with-open-file (out tmp + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede + :if-does-not-exist :create) + (flet ((wline (s) + (write-sequence (map 'vector #'char-code s) out) + (write-byte 13 out) (write-byte 10 out))) + (wline (fmt "From: Loop")) + (wline (fmt "Subject: ~a" subject)) + (wline (fmt "Newsgroups: local.control.news")) + (wline (fmt "Message-ID: ~a" mid)) + (wline (fmt "Date: ~a" (nntp-date-header))) + (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 () (list @@ -1531,7 +1594,8 @@ (new-passwd (or given-passwd random-passwd))) (if (not (get-account username)) (println "No such account ``~a''." username) - (multiple-value-bind (okay? problem) (change-passwd! username new-passwd) + (multiple-value-bind (okay? problem) + (change-passwd! username new-passwd) (if okay? (println "Okay, account ~a now has password ``~a''." username new-passwd) (println "Sorry, could not change password: ~a." problem)))))) @@ -1586,7 +1650,7 @@ (loop (let* ((bs (nntp-read-line)) (ln (bytes->string bs))) - (stderr "<<< ~a~%" ln) ;; for logging + (stderr "<<< ~a~%" ln) (let ((r (send-response! (dispatch-line ln)))) (when (response-quit? r) (return))))) diff --git a/loop.nw b/loop.nw index 8ee48f8..93e52d4 100644 --- a/loop.nw +++ b/loop.nw @@ -36,6 +36,23 @@ \def\nwendcode{\endtrivlist \endgroup} \let\nwdocspar=\par +\usepackage[most]{tcolorbox} +\newtcolorbox{crossedblock}[1][]{ + enhanced, + breakable, + colback=gray!5, + colframe=red!60!black, + boxrule=0.8pt, + arc=1mm, + overlay={ + \draw[red!60!black, line width=1.5pt, opacity=0.4] + (frame.north west) -- (frame.south east); + \draw[red!60!black, line width=1.5pt, opacity=0.4] + (frame.south west) -- (frame.north east); + }, + #1 +} + %% Popular words. \newcommand{\lxxp}{{\tt loop}} \newcommand{\Lp}{{\tt LOOP}} @@ -54,7 +71,7 @@ %\setlength{\parskip}{3pt} %\setlength{\parindent}{0pt} -\Lp\ is an out-of-fashion program, used as medium of communication by +\Lp\ is an out-of-fashion program used as medium of communication by antiquated people. \Lp\ members insist that technical communication be made in writing, anxiety-free. To give you an idea, they write \Lp\ in jurassic technology---you wouldn't pay them any attention. @@ -66,10 +83,10 @@ be made in writing, anxiety-free. To give you an idea, they write -- Mark Knopfler, 1978. \end{verbatim} -It's easy to make a conference on the Internet. E-mail suffices. -When we write an e-mail to various friends to discuss a certain -subject, we form a circle. When we decide to add another person to -this quickly-made conference by e-mail, sometimes we use a well-known +It's easy to make a conference on the Internet: e-mail suffices. When +we write an e-mail to various friends to discuss a certain subject, we +form a circle. When we decide to add another person to this +quickly-made conference by e-mail, sometimes we use a well-known idiom---``adding John to the loop''. We add John's e-mail address to the list of destinataries. So long as everyone replies to everyone, John too will get all the messages. If anyone violates this rule of @@ -197,7 +214,7 @@ just want to use the system, you probably should stop right here. \section*{How to install} See -\href{https://git.antartida.xyz/loop/srv/raw/branch/main/README}{[[README]]} +\href{https://git.atlantida.space/root/loop/raw/branch/main/README}{[[README]]} in \lp's source code. \section{Implementation strategy}\label{sec:design} @@ -306,7 +323,7 @@ with the \lp. You can effectively achieve the same thing using a program such as {\tt telnet}. \begin{verbatim} -C:\>nc antartida.xyz 119 +C:\>nc nntp.atlantida.space 119 200 Welcome! Say ``help'' for a menu. help 200 What's on the menu today? @@ -554,7 +571,7 @@ the user says {\tt QUIT}, then we should identify it and terminate (loop (let* ((bs (nntp-read-line)) (ln (bytes->string bs))) - (stderr "<<< ~a~%" ln) ;; for logging + (stderr "<<< ~a~%" ln) (let ((r (send-response! (dispatch-line ln)))) (when (response-quit? r) (return))))) @@ -716,7 +733,8 @@ running a program [[./list-accounts]]. (new-passwd (or given-passwd random-passwd))) (if (not (get-account username)) (println "No such account ``~a''." username) - (multiple-value-bind (okay? problem) (change-passwd! username new-passwd) + (multiple-value-bind (okay? problem) + (change-passwd! username new-passwd) (if okay? (println "Okay, account ~a now has password ``~a''." username new-passwd) (println "Sorry, could not change password: ~a." problem)))))) @@ -820,11 +838,11 @@ the set of all headers of an article, we can ask [[parse-headers]]. (defstruct article head body) @ %def article-head article-body -\section{How to extract articles from the database} +\section{How to parse articles} We don't extract the entire article from the file system. We first -extract just the headers. If it's ever needed, we read the article -chunk by chunk and hand them to a client that asked for it. +extract just the headers. If it's ever needed, we read the article's +body chunk by chunk and hand each chunk to a client that asked for it. Let's focus now on reading the headers. First, we need to read the bytes off of the file system into memory. What if the article is @@ -852,106 +870,33 @@ the separator even in cases when we had to read it in two calls to [[read-sequence]]. (Such is life in programming.) That's why we subtract 3 from [[start-search]]. If we don't find the separator still, that's because the head is really long, so we repeat. When we -found it, we know that the head starts at zero and goes up to the -position of the separator plus the four bytes of the separator itself. -Why do we include the four bytes in the head? That makes it easy -later one to know where we would find the body---exactly after where -the head ends. +find it, we know that the head starts at zero and goes up to the +position of the separator. The job of parsing an article is to +separate head from body; having the head, we know the body starts 4 +bytes after the length of the head. -\section{How to parse articles} - -Let's now describe how we implement the parsing of articles. The -input is a vector of bytes, bytes that represent the article written -on the file system. First, search for the \verb|\r\n\r\n|, which is -bytes \verb|#(13 10 13 10)|, that separates head and body. The -headers themselves can be turned into a string. For the body, we're -going to use a great feature of Common Lisp---a zero-copy array window -into the original array [[v]], the argument of the procedure. The -feature is requested by the [[:displaced-to]] keyword, which specifies -the original array, where our window begins is specified by the long -offset keyword. The length of our window has to be the entire article -body, which is the length of the vector minus the head and the -separator \verb|\r\n\r\n|, which is 4 bytes long. - -An article that would have no separator and no body would not be an -article. But still, I'd rather be very careful here and create an -empty body if no separator could ever be found. While \Lp would never -create such an article, it could be tomorrow that we might parse -foreign articles for whatever reason. - -<>= -(defun parse-article (v) - (let ((pos (search #(13 10 13 10) v))) - (if pos - (make-article - :head (map 'string #'code-char (subseq v 0 pos)) - :body (make-array (- (length v) (+ pos 4)) - :element-type (array-element-type v) - :displaced-to v - :displaced-index-offset (+ pos 4))) - (make-article - :head (map 'string #'code-char v) - :body (make-array 0 :element-type (array-element-type v)))))) - -(defun hs-space-collapsed (hs) - (cl-ppcre:regex-replace-all (fmt "~a[ ~a]+" (crlf-string) #\tab) hs " ")) - -(defun hs-lines (lines) (str:split (crlf-string) lines)) - -(defun parse-header (header) - (let* ((h (str:collapse-whitespaces header)) - (pos (search ":" h))) - (when (null pos) - (throw 'article-syntax-error - (values nil (fmt "missing colon in header |~a|" h)))) - (when (<= (length h) (+ 2 pos)) - (throw 'article-syntax-error - (values nil (fmt "empty header ~a" h)))) - (multiple-value-bind (key val) - (values (subseq h 0 pos) (subseq h (+ 2 pos))) - (cons (str:downcase key) val)))) - -(defun parse-headers (hs) - (let ((ls (hs-lines (hs-space-collapsed hs)))) - (mapcar #'(lambda (h) (parse-header h)) ls))) - -(defun string-integer? (s) (ignore-errors (parse-integer s))) -@ %def parse-article parse-headers - -We now write some procedures that we use when we're build the {\em - overview} of the command \verb|XOVER|. We write them here because -they're still part of parsing an article. - -<>= -(defun get-header (key hs) - (let ((pair (assoc key hs :test #'string=))) - (if pair (cdr pair) ""))) - -(defun fetch-headers (g i) - (let* ((a-string (fetch-article g i)) - (a-parsed (parse-article a-string)) - (headers (parse-headers (article-head a-parsed)))) - (enrich-headers headers a-string a-parsed))) - -(defun enrich-headers (hs a-raw a-parsed) - (append hs - `(("line-count" . ,(fmt "~a" (nlines (article-body a-parsed)))) - ("byte-count" . ,(fmt "~a" (length a-raw)))))) - -(defun nlines (v) - (loop for b across v - count (= b 10))) -@ %def get-header fetch-headers - -The procedures [[extract-mid]] and [[lookup]] also belong belong in -this section. Do they really? It seems so. - -<>= -(defun extract-mid (a) - (lookup "message-id" (parse-headers (article-head (parse-article a))))) -(defun lookup (key table) - (cdr (assoc key table :test #'string=))) -@ %def extract-mid lookup +<>= +(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)))))))))) +@ %def read-headers-raw \section{How to stream off articles through the network} @@ -974,7 +919,7 @@ array is made but references an already allocated memory. How are articles handled by LOOP? Begin at [[fetch-article]], which depends on [[read-headers-raw]], a procedure that reads only so much of an article so as to consume the entirety of headers, using -[[vector-push-extend]]. So the way only to attack LOOP is to send it +[[vector-push-extend]]. So the only way to attack LOOP is to send it an article whose headers are huge, implying we must limit article's head size, though we don't currently do that. As soon as headers are consumed, [[read-headers-raw]] finishes. @@ -988,12 +933,9 @@ body. The structure records the path of the file and where in the streaming it is; the {\em where} is the current byte to be written to the network, discovered by Lisp's [[file-position]], the portable version of [[POSIX fseek]]. Where does a body begin? An article is -made of a head, a separator and a body. So the body begins at the -separator ends. You can verify this information by reading -[[read-headers-raw]]; notice how it returns the head by adding 4 bytes -after the position of where the separator was found---in other words, -the head includes the separator, so the body begins right where -[[read-headers-raw]] ends. +made of a head, a separator and a body. So the body begins at where +the separator ends. You can verify this information by reading +[[read-headers-raw]]. The product of [[typical-cmd-response]] is a response. When an entire article has been requested---which is what happens when someone issues @@ -1010,11 +952,12 @@ network socket. Why one one by one? To make sure we can do {\em dot-stuffing}, otherwise we could've delegated that job to [[write-sequence]]. -Can we do a better job with respect to the source code writing? Not -really. Procedure [[send-response!]] needs to do different things -based on the type of content. This desired type-dispatching is -performed by [[send-chunk!]] and then we need to write a particular -procedure for handling the file-stream-payload representation. +Can we do a better job with respect to the source code writing? +Procedure [[send-response!]] needs to do different things based on the +type of content. This desired type-dispatching is performed by +[[send-chunk!]] and then we need to write a particular procedure for +handling the file-stream-payload representation. So, not +really---we've done the best we can here. {\bf Dot stuffing}. Should dot stuffing be done on the fly? The alternative would be when storing the article. But, no, we should @@ -1022,6 +965,12 @@ store the article precisely as the user has sent it. It is to be treated as an important historical document. We don't touch user property, which is the article's body. +{\bf Limit header size}. We need to limit head size otherwise we +could suffer an attack of making us allocate too much memory because +the head never ends. We also need to limit article size, otherwise +we'll fill up the file system. Looking for something to do? +Implement these limits---pretty easy task. + <>= (defstruct file-stream-payload (path "" :type string) @@ -1031,36 +980,15 @@ property, which is the article's body. (in-group g (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) "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 here is doing what ftell(3) in C would do (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 + (at-line-start t)) (loop for n = (read-sequence buf in) while (plusp n) do (loop for i from 0 below n @@ -1088,7 +1016,101 @@ property, which is the article's body. (send-chunk! (crlf) *standard-output*)) (force-output) r) -@ %def read-headers-raw fetch-article file-stream-payload +@ %def read-headers-raw fetch-article + +\section{How to parse headers} + +The input is a vector of bytes, bytes that represent the article +written on the file system. First, search for the \verb|\r\n\r\n|, +which is bytes \verb|#(13 10 13 10)|, that separates head and body. +The headers themselves can be turned into a string. For the body, +we're going to use a great feature of Common Lisp---a zero-copy array +window into the original array [[v]], the argument of the procedure. +The feature is requested by the [[:displaced-to]] keyword, which +specifies the original array, where our window begins is specified by +the long offset keyword. The length of our window has to be the +entire article body, which is the length of the vector minus the head +and the separator \verb|\r\n\r\n|, which is 4 bytes long. + +An article that would have no separator and no body would not be an +article. But still, I'd rather be very careful here and create an +empty body if no separator could ever be found. While \Lp would never +create such an article, it could be tomorrow that we might parse +foreign articles for whatever reason. + +<>= +(defun parse-article (v) + (let ((pos (search #(13 10 13 10) v))) + (if pos + (make-article + :head (map 'string #'code-char (subseq v 0 pos)) + :body (make-array (- (length v) (+ pos 4)) + :element-type (array-element-type v) + :displaced-to v + :displaced-index-offset (+ pos 4))) + (make-article + :head (map 'string #'code-char v) + :body (make-array 0 :element-type (array-element-type v)))))) + +(defun hs-space-collapsed (hs) + (cl-ppcre:regex-replace-all (fmt "~a[ ~a]+" (crlf-string) #\tab) hs " ")) + +(defun hs-lines (lines) (str:split (crlf-string) lines)) + +(defun parse-header (header) + (let* ((h (str:collapse-whitespaces header)) + (pos (search ":" h))) + (when (null pos) + (throw 'article-syntax-error + (values nil (fmt "missing colon in header |~a|" h)))) + (when (<= (length h) (+ 2 pos)) + (throw 'article-syntax-error + (values nil (fmt "empty header ~a" h)))) + (multiple-value-bind (key val) + (values (subseq h 0 pos) (subseq h (+ 2 pos))) + (cons (str:downcase key) val)))) + +(defun parse-headers (hs) + (let ((ls (hs-lines (hs-space-collapsed hs)))) + (mapcar #'(lambda (h) (parse-header h)) ls))) + +(defun string-integer? (s) (ignore-errors (parse-integer s))) +@ %def parse-article parse-headers + +We now write some procedures that we use when we're build the {\em + overview} of the command \verb|XOVER|. We write them here because +they're still part of parsing an article. + +<>= +(defun get-header (key hs) + (let ((pair (assoc key hs :test #'string=))) + (if pair (cdr pair) ""))) + +(defun fetch-headers (g i) + (let* ((a-string (fetch-article g i)) + (a-parsed (parse-article a-string)) + (headers (parse-headers (article-head a-parsed)))) + (enrich-headers headers a-string a-parsed))) + +(defun enrich-headers (hs a-raw a-parsed) + (append hs + `(("line-count" . ,(fmt "~a" (nlines (article-body a-parsed)))) + ("byte-count" . ,(fmt "~a" (length a-raw)))))) + +(defun nlines (v) + (loop for b across v + count (= b 10))) +@ %def get-header fetch-headers + +The procedures [[extract-mid]] and [[lookup]] also belong belong in +this section. Do they really? It seems so. + +<>= +(defun extract-mid (a) + (lookup "message-id" (parse-headers (article-head (parse-article a))))) +(defun lookup (key table) + (cdr (assoc key table :test #'string=))) +@ %def extract-mid lookup \section{Commands} @@ -1253,29 +1275,6 @@ that loses the race would have its modifications lost. What do we need to do? We need locking no matter what. <>= -(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! () (with-file-lock ("accounts.lck") (let ((name @@ -1381,7 +1380,8 @@ there is a macro emerging here called [[with-upcase-args]]. %% TODO (multiple-value-bind (cur new) (apply #'values args) (cond ((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? (make-response :code 200 :request r :data "You got it. Password changed.") @@ -1442,10 +1442,10 @@ invited who. (if (locked? (account-username u)) (fmt " (account locked: ~a)" (account-pass-locked-why u)) - "") + "") (if (last-time-seen (account-username u)) (fmt "last seen on ~a" (last-time-seen (account-username u))) - "never logged in") + "never logged in") (or (account-friends u) "nobody")))) #'string<= :key #'(lambda (row) (car row))))) @@ -1459,16 +1459,24 @@ invited who. (let ((u (get-account username))) (if u (let ((s (account-seen u))) (if s (universal-to-human s)))))) -@ %def list-users last-time-seen size-of-longest-username +@ %def list-users \subsection{{\tt LIST}}\label{sec:list} The database of groups and articles is a UNIX directory. We just need to discover which directories exist and produce a listing. The heavy -work here is finding the index interval of articles in the group. (I -think we should already be optimizing this by merely caching the -information in a file that is read at start-up. I think we should -even cache the overview of the group.) %% TODO +work here is finding the index interval of articles in the group. + +\begin{crossedblock} +(I think we should already be optimizing this by merely caching the + information in a file that is read at start-up. I think we should + even cache the overview of the group.) %% TODO +\end{crossedblock} + +I think we can clean up these group structures. We're using +[[values]] and [[multiple-value-bind]] and it suffices right now. +Let's only optimize the things we need to optimize right now---forget +the future for a moment. <>= (defstruct group name high low) @@ -1509,28 +1517,78 @@ even cache the overview of the group.) %% TODO (or (zero-file? path) (cl-ppcre:scan "\.tmp$" (namestring path)))) -(defun article-ready? (path) +(defun article-ready?-old (path) (not (temporary-article? path))) <> - (defun get-articles (g &optional from to) - (in-groups ;; We might want to optimize this some day. That's a - ;; problem to be studied. - (let ((as (articles->integers - (remove-if #'temporary-article? (loop-list-files (truename g)))))) + (in-groups ;; It's okay for this to be slow because we only run this + ;; one time in the birth of a group. + (let ((as (articles->integers (loop-list-files (truename g))))) (sort (remove-if-not #'(lambda (x) (between? x (or from x) (or to x))) as) #'<)))) -(defun group-high-low (g) +(defun group-high-low-fallback (g) (let* ((articles (get-articles g)) (sorted-ints (sort articles #'<))) (values (or (car sorted-ints) 0) (or (car (last sorted-ints)) 0) (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) (remove-if #'null (mapcar #'(lambda (g) @@ -1573,7 +1631,8 @@ To list directories and files, I have been using <>= (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) #+clisp (apply #'directory directory :circle T :if-does-not-exist :ignore args) #+(or cmucl scl) (apply #'directory directory :follow-links NIL :truenamep NIL args) @@ -1637,7 +1696,7 @@ We just need to verify if the group exists and modify [[*client*]]. (setf (client-group *client*) g)) @ %def group? -\subsection{{\tt BODY}, {\tt HEAD}, {\tt ARTICLE} e {\tt NEXT}} +\subsection{{\tt BODY}, {\tt HEAD}, {\tt ARTICLE} and {\tt NEXT}} \label{sec:typical-cmds} Here we have an illustration of the expressive power of first-class @@ -1682,6 +1741,7 @@ Section~\ref{sec:index} for the implementation of the index. (typical-cmd-response 222 r g i :body)) @ +\begin{crossedblock} In processing such commands, we need to verify the existence of files {\em et cetera}. The procedure [[fetch-article]] returns [[nil]] when the article requested doesn't exist and it throws @@ -1691,8 +1751,9 @@ not only to allocate an array at the right size, but also because we must provide the size when producing the \verb|OVERVIEW|. If a problem such as [[sb-posix:syscall-error]] appears, we just inform the client and terminate the request---nothing else to do. +\end{crossedblock} -Our error checking strategy below is the following. If the user +Our error-checking strategy below is the following. If the user requests an article we don't have, we figure it out with [[fetch-article]]. If a system error come up such as a failed system call, we report it to the user and log it---there's probably nothing @@ -1709,19 +1770,20 @@ not ignoring any errors at all. (if (null headers-raw) (make-response :code 400 :request r :data (fmt "article ~a/~a does not exist" g i)) (let* ((a (parse-article headers-raw)) - ;; FIX: Pass the raw bytes to extract-mid, not the parsed struct (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 (ecase requested-part (: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) - (crlf) - (crlf) - (make-file-stream-payload :path path :start-pos header-length)))))) + (crlf) (crlf) + (make-file-stream-payload :path path + :start-pos body-start)))))) (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) (let ((msg (fmt "article ~a/~a: ~a" g i c))) @@ -1756,7 +1818,7 @@ The command \verb|NEXT| has a slight different semantics. (defun mid-by-name (g name) (extract-mid (fetch-article g name))) -@ %def cmd-next article-next! mid-by-name +@ \subsection{{\tt XOVER}}\label{sec:xover} @@ -1827,16 +1889,29 @@ So, we're always in reader mode, so we just ignore this command. \subsection{{\tt DATE}}\label{sec:date} -It's always useful to know the time and date at a computer. We should -surely format it a bit better than what {\tt now} does. +It's always useful to know the time and date at a computer. + +\begin{crossedblock} +We should surely format it a bit better than what {\tt now} does. +\end{crossedblock} <>= +(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) (make-response :code 201 :request r :data - (format-timestring nil (now)))) -@ %def + (nntp-date-command))) +@ %def nntp-date-header \subsection{{\tt QUIT}}\label{sec:quit} @@ -1850,10 +1925,9 @@ says {\tt QUIT}, [[main-loop]] must terminate. \subsection{{\tt DD}}\label{sec:dd} -The command {\tt DD} means ``[d]isplay client [d]ata structures''. It -shows to the client the internal state of how the server sees it. -I've used only for debugging and it's not really useful any longer. -I'm going to remove this very soon. +The command {\tt DD} means ``\underline{d}isplay client +\underline{d}ata structures''. It shows to the client the internal +state of how the server sees it. <>= (defun cmd-dd (r) @@ -1909,16 +1983,18 @@ of trying to stop them. (make-response :code 340 :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 (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) - (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 ;; 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)))))) + (headers-str (bytes->string headers-raw)) + (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 "headers string: ~a~%" headers-str) (multiple-value-bind (okay? error) (conforms-headers? headers-str) @@ -1928,46 +2004,21 @@ of trying to stop them. :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))))))) + (handler-case + (let* ((hash (store-article-in-index! tmp mid))) + (stderr "stored ~a from ~a~%" hash mid) + (dolist (ng ngs) + (let ((new-id (link-article-into-group-insist! hash ng (get-next-article-id ng)))) + (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))))))) @ -It's time to write the action of posting. The article has already been -streamed to a temporary file by [[nntp-read-article-to-disk]]; we hold -only the headers in memory. [[post]] receives the path and the raw -header bytes, ensures {\tt message-id} and {\tt date} are present -(rewriting the temp file only when a header is missing), then places a -copy into each destination group. - -Cross-posting still duplicates the article on the file system for now. -(We will replace the copies with symbolic links once the index work is -finished.) - <>= -(defun post (tmp-path headers-raw) - (let* ((headers-str (map 'string #'code-char - (subseq headers-raw 0 (max 0 (- (length headers-raw) 4))))) - (headers (parse-headers headers-str)) - (ngs (newsgroups-header->list (get-header "newsgroups" headers))) - (body-start (length headers-raw))) - ;; This has gotten complicated. We need to move TMP-PATH into the - ;; first newsgroup and then symlink the article to all other - ;; groups. This means we give a different treatment to - ;; groups. This isn't so good. Looks like we should create a - ;; file-system index of articles and then symlink each article to - ;; each group---a more general treatment. Do this crazy thing now - ;; and then generalize only later once you've cleaned this code up - ;; so much. So here's your NEXT STEP: forget symlinks for now; - ;; copy the temporary article to each directory before you post - ;; it; IMPLEMENT COPY-TEMPORARY-FILE-TO and test the system. - (dolist (ng ngs) - (save-article-insist ng (get-next-article-id ng) tmp-path)) - (values 240 "Thank you! Your article has been saved."))) - (defun newsgroups-header->list (s) (mapcar #'(lambda (n) (str:trim (string-downcase n))) (str:split "," s))) @ %def post @@ -1978,6 +2029,7 @@ finished.) (setf (account-last-post u) (get-universal-time)))) @ %def update-last-post-date! +\begin{crossedblock} The job of [[save-article-try]] is to atomically allocate an article name in a group. The atomicity is achieved with [[:if-exists]] in the [[with-open-file]] macro. When [[if-exists]] is {\tt nil}, the {\tt open} @@ -1985,14 +2037,18 @@ system call uses the flag \verb|O_EXCL|, giving us an atomic operation. So the first [[with-open-file]] allocates the name. If successful, we copy the already-streamed article from [[src-path]] into a temporary file next to it and atomically rename it into place. +\end{crossedblock} <>= (defun rename-no-extension (old new) (rename-file (merge-pathnames old (uiop:getcwd)) (merge-pathnames (make-pathname :name new :type :unspecific) (uiop:getcwd)))) +@ -(defun save-article-try (name-try src-path) - (stderr "going to try to save ~a with name ~a~%" src-path name-try) +\begin{crossedblock} +<>= +(defun save-article-try-old (g name-try tmp-path) + (stderr "going to try to save ~a with name ~a/~a~%" tmp-path g name-try) (let ((name (fmt "~a" name-try)) (tmp (fmt "~a.tmp" name-try))) (with-open-file @@ -2002,60 +2058,69 @@ file next to it and atomically rename it into place. :if-does-not-exist :create) (when (null s) (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~%") - ;; Because of my mess with directory paths, I'm having to do the - ;; ../../ here. This is bad design. We need to find a solution - ;; for this. But don't come up with the use - ;; absolute-paths-solution. Relative paths is always better. + ;; We've been called to save tmp-path to its permanent name. We're + ;; merely going to rename it there. So the rename call is now + ;; tmp/post-tmpfile.tmp to index/bb/bb/hash. To get the hash we + ;; need need the message-id. + (stderr "current-directory: ~a~%" (uiop:getcwd)) (stderr "default-pathname: ~a~%" *default-pathname-defaults*) - (stderr "rename-no-extension ~a ~a~%" (fmt "tmp/~a" src-path) (fmt "groups/local.test/~a" name)) - (rename-no-extension (fmt "../../tmp/~a" src-path) name))) -@ %def save-article-try + ;(stderr "rename-no-extension ~a ~a~%" (fmt "~a" tmp-path) (fmt "~a" name)) + + ;; 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))) +@ The procedure [[save-article-insist]] insists on calling [[save-article-try]] until it finds an article name that has not been allocated. The argument [[name]] is an integer, incremented at each -iteration (and it's the loop for x from x that makes the increments). +iteration (and it's the loop for $x$ from $x$ that makes the +increments). <>= -(defun save-article-insist (g name src-path) +(defun save-article-insist-old (g name src-path) (loop for name from name do - (in-group g - (when (not (eql 'name-exists (save-article-try name src-path))) - (return (values name t)))))) + (when (not (eql 'name-exists (save-article-try-old g name src-path))) + (return (values name t))))) +@ +\end{crossedblock} +<>= (defun get-next-article-id (g) (multiple-value-bind (low high len) (group-high-low g) (declare (ignore low len)) (1+ high))) -@ %def save-article-insist get-next-article-id +@ %def get-next-article-id -{\bf How to read lines in the NNTP protocol?} We need a new -presentation here and a clean up operation. +{\bf How to read lines in the NNTP protocol?} ... <>= (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))) - ;; 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))))) + (ensure-directories-exist "tmp/") + (with-open-file (out tmp-path + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :error) + (loop + (let ((line (nntp-read-line))) + (when (end-of-article? line) + (return tmp-path)) + (let ((start-idx (if (and (> (length line) 0) (= (aref line 0) 46)) 1 0))) + (write-sequence line out :start start-idx))) + (write-byte 13 out) + (write-byte 10 out)))) (defun end-of-article? (ls) ;; A line is the NNTP terminator only if it's exactly the single byte @@ -2265,9 +2330,7 @@ SLIME---and keeps the framing logic completely shared. have exactly \verb|date|, \verb|from|, \verb|message-id|, \verb|newsgroups|, \verb|path| and \verb|subject| headers. The headers \verb|path| is \Lp's responsibility, but it's used only in a -network of servers---so we're leaving that out for now. The header -\verb|message-id| is added by \Lp\ if the client doesn't write it -itself. +network of servers---so we're leaving that out for now. We cannot let the user post to any group if one of the groups is incorrectly named---for example, when the group doesn't exist. Why @@ -2278,21 +2341,12 @@ groups; we would make such plans all go down the drain. So we collect a list of newsgroups that don't exist (or whose names do not conform for any reason); if we find any such group, then we refuse posting and return a 400 code with a message describing which group names failed. -Otherwise the article is susceptible to be saved by [[post]]. +Otherwise the article is susceptible to be saved. So the message here is that if an article is vetted by [[conforms?]], then it can be saved. Any problem with the article must be reported by [[conforms?]]. -Something to think about is that we have a [[catch]] here and a -[[throw]] in [[parse-headers]]. We also have a [[return]] here. It's -getting hard to read this procedure because it's not easy to know that -a procedure has to return a certain value to match the expectation of -another procedure. I don't remember what [[catch]] does. I need to -review this and then add the explanation for myself. If I don't -remember how this works, other beginners won't know it either. It's -unclear right now what the wise measure is, so we'll keep on moving. - <>= (defun conforms? (bs) (catch 'article-syntax-error @@ -2334,8 +2388,9 @@ unclear right now what the wise measure is, so we'll keep on moving. (defun headers-required-from-clients () '("from" "newsgroups" "subject" "message-id" "date")) -@ %def conforms? headers-required-from-clients +@ +\begin{crossedblock} Notice that to simplify matters we're duplicating articles cross-posted. What we should do is write the article to the first group in the list of \verb|newsgroups| and then make a symbolic link @@ -2343,6 +2398,7 @@ to all others. Why are we saying this here? This should be said in the [[post]] procedure. You know what? Let's commit what we have right now and let's tackle the index. We gotta push on through. (But while I'm gone I meant it---everything is gonna be alright.) +\end{crossedblock} \subsection{{\tt CREATE-GROUP}} @@ -2433,67 +2489,38 @@ invitations {\em et cetera} are published there. (defun post-notification (&key subject body) (in-groups (ensure-directories-exist "local.control.news/")) - (when (group? "local.control.news") - (let ((tmp (fmt "notify-~a.tmp" (random-string 10))) - (mid (suggest-message-id))) - (unwind-protect - (progn - (with-open-file (out tmp - :direction :output - :element-type '(unsigned-byte 8) - :if-exists :supersede - :if-does-not-exist :create) - (flet ((wline (s) - (write-sequence (map 'vector #'char-code s) out) - (write-byte 13 out) (write-byte 10 out))) - (wline (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)))))) + (let ((tmp (fmt "tmp/notify-~a.tmp" (random-string 10))) + (mid (suggest-message-id))) + (unwind-protect + (progn + ;; XXX: abstract this away into its own procedure. + (with-open-file (out tmp + :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede + :if-does-not-exist :create) + (flet ((wline (s) + (write-sequence (map 'vector #'char-code s) out) + (write-byte 13 out) (write-byte 10 out))) + (wline (fmt "From: Loop")) + (wline (fmt "Subject: ~a" subject)) + (wline (fmt "Newsgroups: local.control.news")) + (wline (fmt "Message-ID: ~a" mid)) + (wline (fmt "Date: ~a" (nntp-date-header))) + (write-byte 13 out) (write-byte 10 out) + (write-sequence (map 'vector #'char-code body) out) + (write-byte 13 out) (write-byte 10 out))) + (let ((headers-raw (read-headers-raw tmp))) + (post tmp headers-raw))) + (ignore-errors (delete-file tmp))))) @ %def notify-group-created notify-user-created -\section{Algorithm of {\tt split-vector}} +\section{The database of articles}\label{sec:index} -How should we describe the algorithm of [[split-vector]]? The -objective is to consume lists of bytes such as -[[(1 2 3 13 10 4 5 6 13 10 7 8 9)]] and produce lists of bytes -such as [[((1 2 3) (4 5 6) (7 8 9))]]. We use [[search]] to find [[13 10]]. -When we find this line termination, we have its position in the -consumed list. With the position, we collect the line and we iterate -searching for the next line. - -<>= -(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)))))))) -@ %def split-vector - -\section{Article index}\label{sec:index} - -Every NNTP server needs to have an index of articles. Each article is -indexed by its message-id. For example, the article +An NNTP server needs to store articles somewhere. More appropriately +for our presentation, we can begin with the fact that such servers +must have an index of articles. Each article is indexed by its +message-id. For example, the article % \begin{verbatim} From: Eva Lu @@ -2509,68 +2536,90 @@ indexed by its message-id. For example, the article % is indexed by the header {\tt message-id}. If you ask for article {\tt <87plr25js5.fsf@tor.soy>}, \Lp\ will tell you that you can find -the article in group {\tt comp.unix} and its numeric ID is 37. Note -that the number 37 is not inside the article, but only in the name of -the file stored in the file system. The index, therefore, knows in -which file is each {\tt message-id}. This fact implies that you -cannot rename files in the file system---of course not: you'd changing -identifiers inside a database. +the article in group {\tt comp.unix} and its numeric ID is integer, +say 37. Note that the number 37 is not inside the article, but only +in the name of the file stored in the file system. -At this very moment we're designing the index. We're removing all -references to the previous index. We're going to use a two-level UNIX -directory. Every message id will be hashed to a {\tt hashid} and the -hard link on the file system will be written in directory {\tt - index/ha/sh/id}. I believe a two-level will be enough for -\Lp---it's a system for a loop of friends. Though the code is dead, -I'm keeping the next section here because we'll likely keep the -procedure names, so seeing here will remind me what needs to be -rewritten. +How do we store our articles? In a UNIX directory in a way that we +can quickly locate it on the file system. Before storing an article, +we read its headers, so we know its message-id. From the message-id, +we compute a hash of it whose first two bytes determines the +subdirectories in which we can find the article. For example, the +article above has a hash whose first bytes as {\tt "ff9358..."}, so +you would find it at {\tt index/ff/93/ff9358...} -\section{Essential operations relative to the index} +This means we're using a two-level hierarchy for performance reasons. +This is likely not sufficient for the binary USENET, but it's likely +pretty reasonable for the plain-text USENET. We hold the position +that the USENET should be never be nor have been used for binary file +exchange, so we don't even want to support such thing. Keep in mind +that \Lp\ is being designed for a circle of friends, but we are +definitely able to support the large community as well. -Here's how to query the index or how to insert a new article into it. -If [[insert-index]] returns [[nil]], then it's because it found no -errors at all. The return value, therefore, indicates which error -ocurred. +<>= +<> +(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))))) -We don't consider an error that an article has already been added to -the index. For instance, we write multiple messages to the storage -when someone cross-posts, but we'll add just a single record to the -index, of course. So, an article already indexed is normal situation. -Sure---in the future, we will not duplicate articles in storage; we -will make symbolic links. We don't do that right now because Windows -doesn't really support symbolic links. +(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 insert-index (m g i) +(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 - (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))) + (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))))) +@ %def store-article-in-index! link-article-into-group-insist! -(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)))) -@ %def insert-index lookup-index +<>= +(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))))) +@ \section{Procedure to import the index from the file system} +What we now need is a procedure to intern a directory full of +articles. We could have a series of articles somewhere and we would +like to have them all recognized by \Lp. + +\begin{crossedblock} When we build the index from scratch, it's important to have a procedure capable of reading all articles in the file system and index them one by one. This is what we implement right here. For each news @@ -2599,8 +2648,6 @@ Here's a program to build the index from a UNIX shell. <> (ql:quickload :loop :silent t) (in-package #:loop) -(connect-index! "message-id.db") -(drop-create-index!) (index-from-fs!) (format t "Index built.~%") @ @@ -2619,6 +2666,7 @@ Index built. %ls -l message-id.db -rw-r--r-- 1 me wheel 65536 Aug 26 13:32 message-id.db \end{verbatim} +\end{crossedblock} \section{Deletion and locking of inactive accounts}\label{sec:inactive-users} @@ -2635,7 +2683,6 @@ inactive, so I only lock them. (ql:quickload :loop :silent t) (in-package #:loop) (read-accounts!) -(connect-index! "message-id.db") (remove-inactive-users!) (write-accounts!) @ %def cron-remove-inactive-users.lisp @@ -2791,6 +2838,29 @@ example, when we need to access the group database, we use [[with-auth]]. <>= +(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) `(let ((*default-pathname-defaults* (truename ,dir))) (uiop:with-current-directory (,dir) @@ -2908,6 +2978,9 @@ Of small importance, they have nothing. \section{Tests} +I removed the tests. We have done a major rewrite. + +\begin{crossedblock} I studied the minimum to be able to add these tests as we comprehend better the direction in which we're going. A test system is essential for us to trust we can move forward without breaking important past @@ -2961,9 +3034,7 @@ Newsgroups: local.test, bad.newsgroup A bad test from the biggest mouth of the south. ")) @ %def - -I removed the tests. The most central piece of the system has been -rewritten. +\end{crossedblock} \section{How to produce the binary executable} @@ -3063,15 +3134,14 @@ something to think about. <> <> <> -<> -<> <> <> <> -<> <> +<> <> <> +<> <> <> <> @@ -3101,7 +3171,6 @@ something to think about. <> <> <> -<> <> <> <> @@ -3149,7 +3218,7 @@ two blank lines in some cases. We then remove the excess with the second program. Notice we need the {\tt -E} option because we're using the {\tt \textbar} metacharacter. -The second program find a blank line as its first step. Then we say +The second program finds a blank line as its first step. Then we say {\tt N} to expand the pattern space to include the next line. Then we delete the {\em first} blank line and not the second---that's what the {\tt D} command does. This strategy is explained by Dale Dougherty @@ -3183,12 +3252,11 @@ $ git log --oneline | head -1 | awk '{print $1}' \end{verbatim} % We achieve this with [[version.lisp]], which we generate before any -release. This a bit of meta source code we use included in a meta -Makefile we maintain. It's perfectly fine if you assume that -[[version.lisp]] is manually written before we release a new version. -When \Lp\ displays the welcome banner, the procedure -[[welcome-message]] replaces the string [[HASH]] with the hash spelled -out in [[version.lisp]]. +release. This a bit of meta source code we use is included in a meta +Makefile we maintain. You could assume that [[version.lisp]] is +manually written before we release a new version. When \Lp\ displays +the welcome banner, the procedure [[welcome-message]] replaces the +string [[HASH]] with the hash spelled out in [[version.lisp]]. \section*{Index of chunks} \nowebchunks diff --git a/scripts/build-index-from-fs.lisp b/scripts/build-index-from-fs.lisp index e6f9f68..ff24b3a 100644 --- a/scripts/build-index-from-fs.lisp +++ b/scripts/build-index-from-fs.lisp @@ -5,7 +5,5 @@ (load quicklisp-init))) (ql:quickload :loop :silent t) (in-package #:loop) -(connect-index! "message-id.db") -(drop-create-index!) (index-from-fs!) (format t "Index built.~%") diff --git a/scripts/cron-remove-inactive-users.lisp b/scripts/cron-remove-inactive-users.lisp index 6d10913..9d10633 100644 --- a/scripts/cron-remove-inactive-users.lisp +++ b/scripts/cron-remove-inactive-users.lisp @@ -6,6 +6,5 @@ (ql:quickload :loop :silent t) (in-package #:loop) (read-accounts!) -(connect-index! "message-id.db") (remove-inactive-users!) (write-accounts!) diff --git a/version.lisp b/version.lisp index ab030e2..057bbf0 100644 --- a/version.lisp +++ b/version.lisp @@ -1,2 +1,2 @@ (in-package :loop) -(defparameter *git-hash* "9f48666") +(defparameter *git-hash* "d44771c")