A major rewrite: new cmd-post, the index and procedure group-high-low.
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:
parent
602f44b464
commit
05be4aad57
8 changed files with 774 additions and 645 deletions
2
Makefile
2
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`
|
||||
|
|
|
|||
458
loop.lisp
458
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,6 +372,27 @@
|
|||
(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
|
||||
|
|
@ -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)))))
|
||||
|
|
|
|||
|
|
@ -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.~%")
|
||||
|
|
|
|||
|
|
@ -6,6 +6,5 @@
|
|||
(ql:quickload :loop :silent t)
|
||||
(in-package #:loop)
|
||||
(read-accounts!)
|
||||
(connect-index! "message-id.db")
|
||||
(remove-inactive-users!)
|
||||
(write-accounts!)
|
||||
|
|
|
|||
|
|
@ -1,2 +1,2 @@
|
|||
(in-package :loop)
|
||||
(defparameter *git-hash* "9f48666")
|
||||
(defparameter *git-hash* "d44771c")
|
||||
|
|
|
|||
Loading…
Reference in a new issue