1903 lines
72 KiB
Common Lisp
1903 lines
72 KiB
Common Lisp
;;; -*- mode: LISP; syntax: COMMON-LISP; package: LOOP; -*-
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(ql:quickload
|
|
'(:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon
|
|
:filesystem-utils :ironclad/digest/sha256)
|
|
:silent t))
|
|
|
|
(clsql:file-enable-sql-reader-syntax)
|
|
|
|
(defpackage #:loop
|
|
(:use :common-lisp :local-time)
|
|
(:import-from :lisp-unit define-test assert-true)
|
|
(:import-from :org.shirakumo.filesystem-utils
|
|
directory-p list-directories list-files)
|
|
(:import-from :sb-sys interactive-interrupt)
|
|
(:export :main))
|
|
|
|
(in-package #:loop)
|
|
|
|
(defparameter *debug* t)
|
|
(defstruct account username seen last-post friends pass pass-locked pass-locked-why creation)
|
|
(defparameter *accounts* nil)
|
|
(defstruct client group (article 1) (username "ANONYMOUS") (auth? 'no))
|
|
(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)
|
|
(defparameter *months-inactive-allowed* 3)
|
|
(defparameter *months-never-logged-in* 1)
|
|
(defparameter *enable-nntp-repl* t)
|
|
(defstruct nntp-stream-buffer
|
|
(data (make-array 8192 :element-type '(unsigned-byte 8)))
|
|
(head 0 :type fixnum)
|
|
(tail 0 :type fixnum))
|
|
|
|
(defparameter *network-buffer* (make-nntp-stream-buffer))
|
|
|
|
(defun nntp-read-line (&optional (s *standard-input*))
|
|
(nntp-read-line-buffered s *network-buffer*))
|
|
|
|
(defun table-of-commands ()
|
|
`(("GROUP" ,#'cmd-group "sets the current group")
|
|
("LISTGROUP" ,#'cmd-listgroup "lists the exact articles a group has")
|
|
("NEXT" ,#'cmd-next "increments the article pointer")
|
|
("HELP" ,#'cmd-help "displays this menu")
|
|
("LIST" ,#'cmd-list "lists all groups")
|
|
("LIST NEWSGROUPS" ,#'cmd-list "same as LIST")
|
|
("LIST ACTIVE" ,#'cmd-list "same as LIST")
|
|
("LIST OVERVIEW.FMT" ,#'cmd-list "lists xover fields")
|
|
("CAPABILITIES" ,#'cmd-capabilities "displays our capabilities")
|
|
("AUTHINFO" ,#'cmd-authinfo "makes me trust you")
|
|
("LOGIN" ,#'cmd-login "shorter interface to AUTHINFO")
|
|
("HEAD" ,#'cmd-head "fetches article headers")
|
|
("MODE" ,#'cmd-mode "handles the mode request from clients")
|
|
("BODY" ,#'cmd-body "fetches an article body")
|
|
("POST" ,#'cmd-post "posts your article")
|
|
("ARTICLE" ,#'cmd-article "fetches full articles")
|
|
("XOVER" ,#'cmd-xover "fetches the overview database of a group")
|
|
("XHDR" ,#'cmd-xhdr "fetches a specific header from articles")
|
|
("CREATE-GROUP" ,#'cmd-create-group
|
|
"creates a new group so you can discuss your favorite topic")
|
|
("CREATE-ACCOUNT",#'cmd-create-account
|
|
"creates an account so you can invite a friend")
|
|
("PASSWD" ,#'cmd-passwd "changes your password")
|
|
("USERS" ,#'cmd-list-users "lists all users")
|
|
("DD" ,#'cmd-dd "[d]isplays [d]ata: your state of affairs")
|
|
("QUIT" ,#'cmd-quit "politely says good-bye")
|
|
("DATE" ,#'cmd-date "displays the current date at this server")
|
|
("UNLOCK-ACCOUNT" ,#'cmd-unlock-account "unlocks an account")
|
|
("REPL" ,#'cmd-repl "lets you hack away")))
|
|
|
|
(defun set-up-tables! ()
|
|
(labels ((build-commands-assoc (ls)
|
|
(if (null ls)
|
|
nil
|
|
(cons (apply #'make-command-pair (car ls))
|
|
(build-commands-assoc (cdr ls)))))
|
|
(make-command-pair (name fn desc)
|
|
(cons name (make-command :fn fn :verb name :description desc))))
|
|
(setf *commands-assoc*
|
|
(sort
|
|
(build-commands-assoc (table-of-commands))
|
|
#'string-lessp :key #'car))))
|
|
|
|
(defun get-command (key)
|
|
(let ((cmd (assoc key *commands-assoc* :test #'string=)))
|
|
(labels ((unrecognized-command ()
|
|
(make-command
|
|
:fn #'(lambda (r)
|
|
(make-response
|
|
:code 400
|
|
:data "unrecognized command"
|
|
:request r))
|
|
:verb 'unrecognized
|
|
: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)
|
|
,@body)))
|
|
|
|
(defmacro in-tmp (&rest body) `(in-dir "tmp/" ,@body))
|
|
|
|
(defmacro in-groups (&rest body) `(in-dir "groups/" ,@body))
|
|
|
|
(defun in-group-lambda (g fn) (in-dir g (funcall fn)))
|
|
|
|
(defmacro in-group (g &rest body)
|
|
`(in-group-lambda (fmt "groups/~a/" ,g) #'(lambda () ,@body)))
|
|
|
|
(defmacro with-group (g r &rest body)
|
|
(let ((g-var (gensym))
|
|
(r-var (gensym)))
|
|
`(let ((,g-var ,g)
|
|
(,r-var ,r))
|
|
(if (not (group? ,g-var))
|
|
(make-response :code 411 :request ,r-var
|
|
:data (fmt "no such group ``~a''" ,g-var))
|
|
(progn ,@body)))))
|
|
|
|
(defmacro with-n-args (n r &rest body)
|
|
(let ((args-var (gensym))
|
|
(message-var (gensym))
|
|
(n-var n))
|
|
`(let ((,args-var (request-args r))
|
|
(,message-var ,(fmt "bad arguments: needs exactly ~a" n-var)))
|
|
(if (not (= ,n-var (length ,args-var)))
|
|
(make-response :code 400 :request ,r :data ,message-var)
|
|
(progn ,@body)))))
|
|
|
|
(defmacro with-group-set (&rest body)
|
|
(let ((g-var (gensym)))
|
|
`(let ((,g-var (client-group *client*)))
|
|
(if (not ,g-var)
|
|
(bad-input r "must say GROUP first")
|
|
,@body))))
|
|
|
|
(defmacro with-auth (&rest body)
|
|
`(if (not (auth?))
|
|
(make-response :code 400 :data "You must authenticate first.")
|
|
(progn ,@body)))
|
|
|
|
(defun get-file-inode (path)
|
|
"Returns the inode number for PATH or NIL if the file doesn't exist."
|
|
(handler-case
|
|
(sb-posix:stat-ino (sb-posix:stat (uiop:native-namestring path)))
|
|
(sb-posix:syscall-error () nil)))
|
|
|
|
(defun conforms-to? (s re &optional error-msg)
|
|
"Does string S conform to regular expression RE?"
|
|
(let ((okay? (cl-ppcre:scan-to-strings re s)))
|
|
(if okay?
|
|
(values t nil)
|
|
(values nil (or error-msg (fmt "must match ~a" re))))))
|
|
|
|
(defun print/finish (&rest args)
|
|
(apply #'format (cons t args))
|
|
(finish-output))
|
|
|
|
(defun word-plural (n word)
|
|
(let ((table '(("doesn't" . "don't")
|
|
("newsgroup" . "newsgroups"))))
|
|
(let ((w (assoc word table :test #'string=)))
|
|
(if (not w)
|
|
(str:concat word "s") ;; assume s as suffix
|
|
(if (< n 2) (car w) (cdr w))))))
|
|
|
|
(defun plural (v suffix)
|
|
(if (> v 1) suffix ""))
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(defun fmt (cstr &rest args)
|
|
(apply #'format nil (list* cstr args))))
|
|
|
|
(defun out (stream &rest args)
|
|
(apply #'format (cons stream args)))
|
|
|
|
(defun stderr (&rest args)
|
|
(when *debug*
|
|
(apply #'out (cons *error-output* args))
|
|
(finish-output *error-output*)))
|
|
|
|
(defun stdout (&rest args)
|
|
(apply #'out (list* *standard-output* args)))
|
|
|
|
(defun println (&rest args)
|
|
(apply #'out (list* *standard-output* (str:concat (car args) "~%") (cdr args))))
|
|
|
|
(defun bad-input (r msg &key code)
|
|
(make-response :code (or code 400) :data msg :request r))
|
|
|
|
(defun integer->string (n)
|
|
(fmt "~a" n))
|
|
|
|
(defun crlf ()
|
|
(vector 13 10))
|
|
|
|
(defun crlf-string ()
|
|
(fmt "~c~c" #\return #\linefeed))
|
|
|
|
(defmacro mac (&rest body)
|
|
`(macroexpand-1 ,@body))
|
|
|
|
(defun repl (r)
|
|
(in-package :loop)
|
|
(loop
|
|
(print/finish "LOOP> ")
|
|
(handler-case
|
|
(let ((expr (read)))
|
|
(if (eq 'quit expr)
|
|
(progn
|
|
(return
|
|
(make-response
|
|
:code 200 :request r
|
|
:data "Okay, that's enough hacking for today.")))
|
|
(println "~a" (eval expr))))
|
|
(end-of-file ()
|
|
(print/finish "^D~%")
|
|
(uiop:quit 0))
|
|
(interactive-interrupt ()
|
|
(print/finish "^C~%")
|
|
(uiop:quit 0))
|
|
(t (c)
|
|
(print/finish
|
|
"Oops: ~a~%"
|
|
(str:collapse-whitespaces
|
|
(str:replace-all (string #\linefeed) " " (fmt "~a" c))))))))
|
|
|
|
(defun empty-response () (make-response :code 400 :data "I beg your pardon?"))
|
|
|
|
(defun prepend-response-with (message r)
|
|
(make-response
|
|
:code (response-code r)
|
|
:data (list message (crlf) (response-data r))
|
|
:multi-line (response-multi-line r)
|
|
:request (response-request r)))
|
|
|
|
(defun parse-request (r)
|
|
(let* ((collapsed-s (str:collapse-whitespaces (request-said r)))
|
|
(ls (str:split " " collapsed-s :omit-nulls 'please)))
|
|
;; What are we going to do with a null request?
|
|
(cond ((null ls) (make-request :said (request-said r)))
|
|
(t (let ((verb (car ls))
|
|
(args (cdr ls)))
|
|
(make-request :said (request-said r)
|
|
:verb (str:upcase verb)
|
|
:args args))))))
|
|
|
|
(defun remove-inactive-users! ()
|
|
(loop for u in *accounts* do
|
|
(let ((username (account-username u)))
|
|
(cond ((and (not (locked? username))
|
|
(inactive-from-never-logged-in? username))
|
|
(post-notification
|
|
:subject (fmt "account ~a removed by Loop" username)
|
|
:body (fmt "~a didn't log in a first time (for ~a month~a) since account creation."
|
|
username *months-never-logged-in*
|
|
(plural *months-never-logged-in* "s")))
|
|
(remove-account! username)
|
|
(format t "Removed ~a due to never logging in.~%" username))
|
|
((and (not (locked? username))
|
|
(inactive-from-last-seen? username))
|
|
(post-notification
|
|
:subject (fmt "account ~a locked by Loop" username)
|
|
:body (fmt "~a disappeared for over ~a month~a."
|
|
username *months-inactive-allowed*
|
|
(plural *months-inactive-allowed* "s")))
|
|
(lock-account! username
|
|
(fmt "disappeared for over ~a months"
|
|
*months-inactive-allowed*))
|
|
(format t "Locked ~a due to long-time-no-see.~%" username))))))
|
|
|
|
(defun remove-account! (username)
|
|
(loop for u in *accounts* do
|
|
(setf (account-friends u)
|
|
(delete username (account-friends u) :test #'equal)))
|
|
(setf *accounts*
|
|
(delete-if #'(lambda (a) (equal (account-username a) username))
|
|
*accounts*)))
|
|
|
|
(defun lock-account! (username why)
|
|
(let ((u (get-account username)))
|
|
(setf (account-pass-locked u) (account-pass u))
|
|
(setf (account-pass u) "locked")
|
|
(setf (account-pass-locked-why u) why)))
|
|
|
|
(defun user-inactive? (username)
|
|
(or (inactive-from-never-logged-in? username)
|
|
(inactive-from-last-seen? username)))
|
|
|
|
(defun inactive-from-never-logged-in? (username)
|
|
(let ((u (get-account username)))
|
|
(if (ever-logged-in? username)
|
|
NIL
|
|
(inactive-from? username *months-never-logged-in*
|
|
#'(lambda () (account-creation u))))))
|
|
|
|
(defun locked? (username)
|
|
(equal "locked" (account-pass (get-account username))))
|
|
|
|
(defun inactive-from-last-post? (username)
|
|
(let ((last-post (account-last-post (get-account username)))
|
|
(creation (account-creation (get-account username))))
|
|
(inactive-from? username *months-inactive-allowed*
|
|
(if last-post
|
|
#'(lambda () last-post)
|
|
#'(lambda () creation)))))
|
|
|
|
(defun inactive-from-last-seen? (username)
|
|
(let* ((u (get-account username))
|
|
(last-seen (account-seen u))
|
|
(creation (account-creation u)))
|
|
(inactive-from? username *months-inactive-allowed*
|
|
(if last-seen
|
|
#'(lambda () last-seen)
|
|
#'(lambda () creation)))))
|
|
|
|
(defun inactive-from? (username months timestamp-source)
|
|
(declare (ignore username))
|
|
(timestamp<
|
|
(timestamp+
|
|
(universal-to-timestamp
|
|
(funcall timestamp-source)) months :month)
|
|
(now)))
|
|
|
|
(defun ever-logged-in? (username)
|
|
(account-seen (get-account username)))
|
|
|
|
(defun never-logged-in? (username)
|
|
(not (ever-logged-in? username)))
|
|
|
|
(defun list-inactive-users ()
|
|
(loop for u in *accounts* do
|
|
(format t "Username ~a is inactive? ~a~%"
|
|
(account-username u)
|
|
(user-inactive? (account-username u)))))
|
|
|
|
(defun loop-epoch ()
|
|
(encode-timestamp 0 0 0 0 1 1 2024))
|
|
|
|
(defun migrate-add-creation-and-post-date! ()
|
|
(read-accounts!)
|
|
(loop for u in *accounts*
|
|
do (if (not (account-creation u))
|
|
(setf (account-creation u) (timestamp-to-universal (loop-epoch)))
|
|
(setf (account-last-post u) (account-seen u))))
|
|
(write-accounts!))
|
|
|
|
(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
|
|
: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))
|
|
|
|
(define-condition article-syntax-error (error)
|
|
((message :initarg :message :reader article-syntax-error-message))
|
|
(:report (lambda (condition stream)
|
|
(format stream "~a" (article-syntax-error-message condition)))))
|
|
|
|
(defun article-syntax-error! (fmt-str &rest args)
|
|
(error 'article-syntax-error
|
|
:message (apply #'fmt fmt-str args)))
|
|
|
|
(defun parse-header (header)
|
|
(let* ((h (str:collapse-whitespaces header))
|
|
(pos (search ":" h)))
|
|
(when (null pos)
|
|
(article-syntax-error! (fmt "missing colon in header |~a|" h)))
|
|
(when (<= (length h) (+ 2 pos))
|
|
(article-syntax-error! (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)))
|
|
|
|
(defun get-header (key hs)
|
|
(let ((pair (assoc key hs :test #'string=)))
|
|
(if pair (cdr pair) "")))
|
|
|
|
(defun fetch-headers (g i)
|
|
"Loads the article, parses headers, and computes missing metadata dynamically."
|
|
(let* ((art-path (fmt "groups/~a/~a" g i))
|
|
(a-string (fetch-article g i))
|
|
(a-parsed (parse-article a-string))
|
|
(headers (parse-headers (article-head a-parsed))))
|
|
(enrich-headers headers art-path)))
|
|
|
|
(defun fetch-headers-destroy (g i)
|
|
(let* ((a-string (fetch-article g i))
|
|
(a-parsed (parse-article a-string))
|
|
(headers (parse-headers (article-head a-parsed))))
|
|
headers))
|
|
|
|
(defun enrich-headers (hs art-path)
|
|
"Dynamically computes bytes and lines to the parsed header alist."
|
|
(append hs
|
|
`(("bytes" . ,(fmt "~a" (filesize art-path)))
|
|
("lines" . ,(fmt "~a" (count-lines-at-path art-path))))))
|
|
|
|
(defun count-lines-at-path (path)
|
|
"Constant-memory---8 KiB---line counter."
|
|
(with-open-file (in path :direction :input :element-type '(unsigned-byte 8))
|
|
(let ((buf (make-array 8192 :element-type '(unsigned-byte 8)))
|
|
(lines 0))
|
|
(declare (type (simple-array (unsigned-byte 8) (8192)) buf)
|
|
(type fixnum lines)
|
|
(optimize (speed 3) (safety 1)))
|
|
(loop for n fixnum = (read-sequence buf in)
|
|
while (plusp n)
|
|
do (loop for i fixnum from 0 below n
|
|
when (= (aref buf i) 10)
|
|
do (incf lines)))
|
|
lines)))
|
|
|
|
(defun extract-mid (a)
|
|
(lookup "message-id" (parse-headers (article-head (parse-article a)))))
|
|
|
|
(defun lookup (key table)
|
|
(cdr (assoc key table :test #'string=)))
|
|
(defstruct file-stream-payload
|
|
(path "" :type string)
|
|
(start-pos 0 :type integer))
|
|
|
|
(defun fetch-article (g i)
|
|
(in-group g
|
|
(read-headers-raw (fmt "~a" i))))
|
|
|
|
(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))
|
|
(loop for n = (read-sequence buf in)
|
|
while (plusp n)
|
|
do (loop for i from 0 below n
|
|
for byte = (aref buf i)
|
|
do (when (and at-line-start (= byte 46)) ; 46 is '.'
|
|
(write-byte 46 out-stream))
|
|
(write-byte byte out-stream)
|
|
(setf at-line-start (= byte 10)))))))
|
|
|
|
(defun send-chunk! (chunk s)
|
|
(etypecase chunk
|
|
(string (write-sequence (string->bytes chunk) s))
|
|
(vector (write-sequence chunk s))
|
|
(list (dolist (c chunk) (send-chunk! c s)))
|
|
(integer (write-byte chunk s))
|
|
(file-stream-payload (stream-file-to-socket chunk s))))
|
|
|
|
(defun send-response! (r)
|
|
(send-chunk! (integer->string (response-code r)) *standard-output*)
|
|
(send-chunk! " " *standard-output*)
|
|
(send-chunk! (response-data r) *standard-output*)
|
|
(send-chunk! (crlf) *standard-output*)
|
|
(when (response-multi-line r)
|
|
(send-chunk! "." *standard-output*)
|
|
(send-chunk! (crlf) *standard-output*))
|
|
(force-output)
|
|
r)
|
|
|
|
(defun 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)
|
|
(empty-response)
|
|
(funcall (command-fn (get-command verb)) r))))
|
|
|
|
(defun dispatch-line (ln)
|
|
(dispatch (parse-request (make-request :said ln))))
|
|
|
|
(defun cmd-capabilities (r)
|
|
(prepend-response-with
|
|
"We are very capable! Please, take note:"
|
|
(make-response
|
|
:code 101 :multi-line 'yes :request r
|
|
:data (str:join (crlf-string) (capabilities-lines)))))
|
|
|
|
(defun capabilities-lines ()
|
|
(append
|
|
(list "VERSION 2"
|
|
"READER")
|
|
(when (auth?) (list "POST"))
|
|
(list "AUTHINFO USER"
|
|
"LIST ACTIVE NEWSGROUPS OVERVIEW.FMT"
|
|
(fmt "IMPLEMENTATION LOOP ~a" *git-hash*))))
|
|
|
|
(defun cmd-authinfo (r)
|
|
(let* ((args (mapcar #'str:upcase (request-args r))))
|
|
(cond
|
|
((not (= (length args) 2))
|
|
(bad-input r "No, no: I take exactly two arguments."))
|
|
(t
|
|
(multiple-value-bind (cmd arg) (apply #'values args)
|
|
(cond
|
|
((string= cmd "USER")
|
|
(setf (client-username *client*) arg)
|
|
(make-response :code 381 :request r
|
|
:data (fmt "Hey, ~a, please tell us your password." arg)))
|
|
((string= cmd "PASS")
|
|
(if (authinfo-check (client-username *client*) arg)
|
|
(progn
|
|
(log-user-in!)
|
|
(make-response
|
|
:code 281 :request r
|
|
:data (fmt "Welcome, ~a." (client-username *client*))))
|
|
(make-response :code 400 :request r :data "Sorry. Wrong password.")))
|
|
(t (make-response :code 400 :request r :data "Syntax error. Say ``authinfo USER /your-name/'' then ``authinfo PASS /your-pass/''."))))))))
|
|
|
|
(defun authinfo-check (username passwd)
|
|
(pass? username passwd))
|
|
|
|
(defun auth? ()
|
|
(eq 'yes (client-auth? *client*)))
|
|
|
|
(defun log-user-in! ()
|
|
(setf (client-auth? *client*) 'yes)
|
|
(let ((u (get-account (client-username *client*))))
|
|
(setf (account-seen u) (get-universal-time)))
|
|
(write-accounts!))
|
|
|
|
(defun cmd-mode (r) ;; Whatever.
|
|
(make-response :code 200 :request r :data "Sure thing."))
|
|
|
|
(defun typical-cmd-head-body-article (r fn-by-number fn-by-mid)
|
|
(with-auth
|
|
(let ((args (request-args r)))
|
|
(cond ((null args)
|
|
(with-group-set
|
|
(funcall fn-by-number r (client-group *client*) (client-article *client*))))
|
|
((= 1 (length args))
|
|
(let* ((n-or-mid (car args)))
|
|
(cond ((string-integer? n-or-mid)
|
|
(with-group-set
|
|
(funcall fn-by-number r (client-group *client*) n-or-mid)))
|
|
(t (funcall fn-by-mid r n-or-mid)))))
|
|
(t (bad-input r "No, no: it takes at most two arguments."))))))
|
|
|
|
(defun cmd-head (r)
|
|
(typical-cmd-head-body-article r #'head-response #'head-response-by-mid))
|
|
|
|
(defun cmd-body (r)
|
|
(typical-cmd-head-body-article r #'body-response #'body-response-by-mid))
|
|
|
|
(defun cmd-article (r)
|
|
(typical-cmd-head-body-article r #'article-response #'article-response-by-mid))
|
|
|
|
(defun article-response (r g i)
|
|
(typical-cmd-response 220 r g i :article))
|
|
|
|
(defun head-response (r g i)
|
|
(typical-cmd-response 221 r g i :head))
|
|
|
|
(defun body-response (r g i)
|
|
(typical-cmd-response 222 r g i :body))
|
|
|
|
(defun article-response-by-mid (r mid)
|
|
(typical-cmd-response-by-mid 220 r mid :article))
|
|
|
|
(defun head-response-by-mid (r mid)
|
|
(typical-cmd-response-by-mid 221 r mid :head))
|
|
|
|
(defun body-response-by-mid (r mid)
|
|
(typical-cmd-response-by-mid 222 r mid :body))
|
|
|
|
(defun typical-cmd-response-at-path (code r path error-label response-number requested-part
|
|
&optional (not-found-code 400))
|
|
(handler-case
|
|
(let* ((headers-raw (read-headers-raw path)))
|
|
(if (null headers-raw)
|
|
(make-response :code 400 :request r :data (fmt "article ~a does not exist" error-label))
|
|
(let* ((a (parse-article headers-raw))
|
|
(mid (extract-mid 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 body-start))
|
|
(:article (list (article-head a)
|
|
(crlf) (crlf)
|
|
(make-file-stream-payload :path path
|
|
:start-pos body-start))))))
|
|
(prepend-response-with (fmt "~a ~a" response-number mid)
|
|
(make-response :multi-line 'yes :code code
|
|
:request r :data payload)))))
|
|
(file-error (c)
|
|
(declare (ignore c))
|
|
(make-response :code not-found-code :request r
|
|
:data (fmt "Sorry, no such article ~a." error-label)))
|
|
(sb-posix:syscall-error (c)
|
|
(let ((msg (fmt "article ~a: ~a" error-label c)))
|
|
(stderr msg)
|
|
(make-response :code 400 :request r :data msg)))
|
|
(error (c)
|
|
(let ((msg (fmt "sorry ~a: ~a" error-label c)))
|
|
(stderr msg)
|
|
(make-response :code 400 :request r :data msg)))))
|
|
|
|
(defun typical-cmd-response (code r g i requested-part)
|
|
(typical-cmd-response-at-path
|
|
code r
|
|
(fmt "groups/~a/~a" g i)
|
|
(fmt "~a/~a" g i) i requested-part 423))
|
|
|
|
(defun typical-cmd-response-by-mid (code r mid requested-part)
|
|
(typical-cmd-response-at-path
|
|
code r
|
|
(index-path (index-hash mid))
|
|
mid
|
|
0 requested-part 400))
|
|
|
|
(defun cmd-next (r)
|
|
(with-auth
|
|
(let ((g (client-group *client*))
|
|
(n-cur (client-article *client*)))
|
|
(cond
|
|
((not g) (bad-input :code 412 r "must say GROUP first"))
|
|
(t (multiple-value-bind (low high len) (group-high-low g)
|
|
(declare (ignore low len))
|
|
(cond ((= n-cur high) (bad-input r "you are at the last article already"))
|
|
(t (article-next! r g)))))))))
|
|
|
|
(defun article-next! (r g)
|
|
(setf (client-article *client*) (1+ (client-article *client*)))
|
|
(let ((cur (client-article *client*)))
|
|
(make-response :code 223
|
|
:request r
|
|
:data (fmt "~a ~a" cur (mid-by-name g cur)))))
|
|
|
|
(defun mid-by-name (g name)
|
|
(extract-mid (fetch-article g name)))
|
|
|
|
(defun cmd-xover (r)
|
|
(with-auth
|
|
(with-group-set
|
|
(let ((args (request-args r)))
|
|
(cond ((null args)
|
|
(xover r (client-article *client*) (client-article *client*)))
|
|
((= 1 (length args))
|
|
(multiple-value-bind (s v)
|
|
(cl-ppcre:scan-to-strings "([0-9]+)([-]?)([0-9]*)" (car args))
|
|
(cond
|
|
((not s) (make-response :code 502 :request r :data "bad syntax"))
|
|
(t (let ((fr (parse-integer (aref v 0)))
|
|
(hifen (aref v 1))
|
|
(to (ignore-errors (parse-integer (aref v 2)))))
|
|
(when (not (string= hifen "-"))
|
|
(setq to fr))
|
|
(xover r fr to))))))
|
|
(t (make-response :code 502 :request r :data "bad syntax")))))))
|
|
|
|
(defun xover (r from to)
|
|
(assert (client-group *client*))
|
|
(let* ((g (client-group *client*))
|
|
(ls (get-articles g from to)))
|
|
(cond ((= 0 (length ls))
|
|
(make-response :code 420 :request r :data "no articles in the range"))
|
|
(t
|
|
(prepend-response-with
|
|
"Okay, your overview follows..."
|
|
(make-response
|
|
:code 224 :request r :multi-line 'yes
|
|
:data (str:join
|
|
(crlf-string)
|
|
(loop for i in ls
|
|
collect (xover-format-line
|
|
i
|
|
(remove-if-not
|
|
#'(lambda (h)
|
|
(member (car h) (xover-headers)
|
|
:test #'string=))
|
|
(fetch-headers g i)))))))))))
|
|
|
|
(defun xover-format-line-new (i hs)
|
|
(str:concat (fmt "~a~a" i #\tab)
|
|
(str:join #\tab (mapcar #'(lambda (h) (or (get-header h hs) ""))
|
|
(xover-headers)))))
|
|
|
|
(defun xover-format-line (i hs)
|
|
(str:concat (fmt "~a~a" i #\tab)
|
|
(str:join #\tab
|
|
(mapcar #'(lambda (h) (get-header h hs))
|
|
(xover-headers)))))
|
|
|
|
(defun xover-headers ()
|
|
'("subject" "from" "date" "message-id" "references" "bytes" "lines"))
|
|
|
|
(defun cmd-xhdr (r)
|
|
(with-auth
|
|
(with-group-set
|
|
(let ((args (request-args r)))
|
|
(cond
|
|
((or (null args) (> (length args) 2))
|
|
(make-response :code 502 :request r
|
|
:data "bad syntax: usage is XHDR header [range|message-id]"))
|
|
(t
|
|
(let ((header (string-downcase (car args)))
|
|
(range-arg (cadr args)))
|
|
(cond
|
|
((null range-arg)
|
|
(xhdr r header (client-article *client*) (client-article *client*)))
|
|
((message-id-syntax? range-arg)
|
|
(xhdr-by-message-id r header range-arg))
|
|
(t
|
|
(multiple-value-bind (fr to) (parse-range range-arg)
|
|
(if (not fr)
|
|
(make-response :code 502 :request r :data "bad syntax")
|
|
(xhdr r header fr to))))))))))))
|
|
|
|
(defun message-id-syntax? (s)
|
|
(and (> (length s) 0) (char= (char s 0) #\<)))
|
|
|
|
(defun parse-range (s)
|
|
"Parses S of the form N, N-, or N-M. Returns (values from to), or
|
|
(values nil nil) when S doesn't conform."
|
|
(multiple-value-bind (matched v) (cl-ppcre:scan-to-strings "([0-9]+)([-]?)([0-9]*)" s)
|
|
(if (not matched)
|
|
(values nil nil)
|
|
(let ((fr (parse-integer (aref v 0)))
|
|
(hifen (aref v 1))
|
|
(to (ignore-errors (parse-integer (aref v 2)))))
|
|
(values fr (if (string= hifen "-") to fr))))))
|
|
|
|
(defun xhdr (r header from to)
|
|
(assert (client-group *client*))
|
|
(let* ((g (client-group *client*))
|
|
(ls (get-articles g from to)))
|
|
(cond ((= 0 (length ls))
|
|
(make-response :code 420 :request r :data "no articles in the range"))
|
|
(t
|
|
(prepend-response-with
|
|
(fmt "~a header follows" header)
|
|
(make-response
|
|
:code 221 :request r :multi-line 'yes
|
|
:data (str:join
|
|
(crlf-string)
|
|
(loop for i in ls
|
|
collect (xhdr-format-line i (get-header header (fetch-headers g i)))))))))))
|
|
|
|
(defun xhdr-by-message-id (r header mid)
|
|
(multiple-value-bind (g n) (lookup-by-message-id mid)
|
|
(if (not (and g n))
|
|
(make-response :code 430 :request r :data "no such article")
|
|
(handler-case
|
|
(prepend-response-with
|
|
(fmt "~a header follows" header)
|
|
(make-response :code 221 :request r :multi-line 'yes
|
|
:data (xhdr-format-line 0 (get-header header (fetch-headers g n)))))
|
|
(error (c)
|
|
(declare (ignore c))
|
|
(make-response :code 430 :request r :data "no such article"))))))
|
|
|
|
(defun xhdr-format-line (i value)
|
|
(fmt "~a ~a" i value))
|
|
|
|
(defun cmd-group (r)
|
|
(with-auth
|
|
(with-n-args 1 r
|
|
(let ((g (car (request-args r))))
|
|
(with-group g r
|
|
(set-group! g)
|
|
(multiple-value-bind (low high len) (group-high-low g)
|
|
(let ((ln (fmt "~a ~a ~a ~a" len low high g)))
|
|
(setf (client-article *client*) low)
|
|
(make-response :code 211 :request r :data ln))))))))
|
|
|
|
(defun group? (g)
|
|
(in-groups
|
|
(ignore-errors (directory-p g))))
|
|
|
|
(defun set-group! (g)
|
|
(setf (client-group *client*) g))
|
|
(defstruct group name high low)
|
|
|
|
(defun cmd-list (r)
|
|
(let* ((args (request-args r))
|
|
(keyw (and (= 1 (length args)) (car args))))
|
|
(cond
|
|
((or (null args) (member keyw '("NEWSGROUPS" "ACTIVE") :test #'string-equal))
|
|
(list-groups-response r))
|
|
((and keyw (string-equal keyw "OVERVIEW.FMT"))
|
|
(list-overview-fmt-response r))
|
|
(t (make-response :code 503 :request r
|
|
:data (fmt "Unsupported LIST variant ``~a''." (str:join " " args)))))))
|
|
|
|
(defun list-groups-response (r)
|
|
(prepend-response-with
|
|
"Get in the loop! Lots to choose from."
|
|
(make-response :code 215 :multi-line 'yes
|
|
:data (str:join (crlf-string) (build-groups-lines (build-groups-structs)))
|
|
:request r)))
|
|
|
|
(defun list-overview-fmt-response (r)
|
|
(prepend-response-with
|
|
"What to expect in XOVER? These."
|
|
(make-response :code 215 :multi-line 'yes
|
|
:data (str:join (crlf-string) (overview-fmt-lines))
|
|
:request r)))
|
|
|
|
(defun overview-fmt-lines ()
|
|
'("From:"
|
|
"Date:"
|
|
"Message-ID:"
|
|
"References:"
|
|
"Bytes:"
|
|
"Lines:"
|
|
"Xref:full"))
|
|
|
|
(defun build-groups-lines (ls)
|
|
(reverse
|
|
(mapcar
|
|
#'(lambda (g)
|
|
(fmt "~a ~a ~a y" (group-name g) (group-high g) (group-low g)))
|
|
ls)))
|
|
|
|
(defun build-groups-structs ()
|
|
(let ((ret-ls nil))
|
|
(dolist (g (list-groups) ret-ls)
|
|
(multiple-value-bind (low high len) (group-high-low g)
|
|
(declare (ignore len))
|
|
(setf ret-ls (cons (make-group :name g :high high :low low) ret-ls))))))
|
|
|
|
(defun between? (x from to)
|
|
(<= from x to))
|
|
(declaim (inline between?))
|
|
|
|
(defun filesize (path)
|
|
(sb-posix:stat-size
|
|
(sb-posix:stat path)))
|
|
|
|
(defun zero-file? (path)
|
|
(= (filesize path) 0))
|
|
|
|
(defun temporary-article? (path)
|
|
(or (zero-file? path)
|
|
(cl-ppcre:scan "\.tmp$" (namestring 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)
|
|
#+(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)
|
|
#+lispworks (apply #'directory directory :link-transparency NIL args)
|
|
#+sbcl (apply #'directory directory :resolve-symlinks NIL args)
|
|
#-(or allegro clozure digitool clisp cmucl scl lispworks sbcl)
|
|
(apply #'directory directory args))
|
|
|
|
(defun loop-list-files (directory)
|
|
(let ((directory (pathname-utils:to-directory directory)))
|
|
(let* ((directory (pathname-utils:pathname* directory))
|
|
(entries
|
|
(ignore-errors
|
|
(loop-directory*
|
|
(merge-pathnames pathname-utils:*wild-file* directory)))))
|
|
(remove-if #'directory-p entries))))
|
|
|
|
(defun loop-list-directories (directory)
|
|
(let ((directory (pathname-utils:to-directory directory)))
|
|
(let* (#-(or abcl cormanlisp genera xcl)
|
|
(wild (merge-pathnames
|
|
#-(or abcl allegro cmucl lispworks sbcl scl xcl)
|
|
pathname-utils:*wild-directory*
|
|
#+(or abcl allegro cmucl lispworks sbcl scl xcl) "*.*"
|
|
directory))
|
|
(dirs
|
|
#+(or abcl xcl) (system:list-directory directory)
|
|
#+cormanlisp (cl::directory-subdirs directory)
|
|
#+genera (handler-case (loop for (p . k) in (fs:directory-list directory)
|
|
when (eql :directory k) collect p)
|
|
(fs:directory-not-found () nil))
|
|
#+clozure (ignore-errors (directory* wild :directories T :files NIL))
|
|
#+mcl (ignore-errors (directory* wild :directories T))
|
|
#-(or abcl xcl cormanlisp genera clozure mcl) (loop-directory* wild)))
|
|
(loop for path in dirs
|
|
when (directory-p path)
|
|
collect (pathname-utils:force-directory path)))))
|
|
|
|
(defun get-articles (g &optional from to)
|
|
(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-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)
|
|
(ignore-errors
|
|
(parse-integer (basename (uiop:unix-namestring g)))))
|
|
ls)))
|
|
|
|
(defun list-groups ()
|
|
(let ((groups (in-groups (loop-list-directories (truename ".")))))
|
|
(sort (mapcar #'(lambda (g) (basename (uiop:unix-namestring g))) groups)
|
|
#'string-lessp)))
|
|
|
|
(defun last-char (s) (char s (1- (length s))))
|
|
|
|
(defun basename (path)
|
|
(let ((s (str:collapse-whitespaces path)))
|
|
(if (char= #\/ (last-char s))
|
|
(car (last (pathname-directory s)))
|
|
(file-namestring s))))
|
|
|
|
(defun parse-nntp-range (range-str default-low default-high)
|
|
"Parses an NNTP range string into (values low high)."
|
|
(if (null range-str)
|
|
(values default-low default-high)
|
|
(let ((dash-pos (position #\- range-str)))
|
|
(if (not dash-pos) ;; Didn't find a dash.
|
|
(let ((n (parse-integer range-str :junk-allowed t)))
|
|
(values (or n default-low) (or n default-high)))
|
|
(let ((start-val (parse-integer (subseq range-str 0 dash-pos) :junk-allowed t))
|
|
(end-str (subseq range-str (1+ dash-pos))))
|
|
(if (string= end-str "")
|
|
;; Found an article number followed by a dash as in
|
|
;; 123-.
|
|
(values (or start-val default-low) default-high)
|
|
;; Found an article number followed by a dash and
|
|
;; another number as in 123-456.
|
|
(let ((end-val (parse-integer end-str :junk-allowed t)))
|
|
(values (or start-val default-low) (or end-val default-high)))))))))
|
|
|
|
(defun cmd-listgroup (r)
|
|
(with-auth
|
|
(let* ((args (request-args r))
|
|
(g (if args (car args) (client-group *client*)))
|
|
(range-arg (if (> (length args) 1) (cadr args) nil)))
|
|
(cond
|
|
((> (length args) 2)
|
|
(make-response :code 400 :request r :data "No, no: LISTGROUP takes at most two arguments."))
|
|
((not g)
|
|
(make-response :code 412 :request r :data "No newsgroup selected"))
|
|
(t
|
|
(with-group g r
|
|
(set-group! g)
|
|
(multiple-value-bind (group-low group-high group-len) (group-high-low g)
|
|
(multiple-value-bind (req-low req-high)
|
|
(parse-nntp-range range-arg group-low group-high)
|
|
(let* ((all-articles (get-articles g group-low group-high))
|
|
(filtered-articles (remove-if-not (lambda (x) (and (>= x req-low) (<= x req-high)))
|
|
all-articles)))
|
|
(when all-articles
|
|
(setf (client-article *client*) (car all-articles)))
|
|
(prepend-response-with (fmt "~a ~a ~a ~a list follows" group-len group-low group-high g)
|
|
(make-response :code 211
|
|
:request r
|
|
:multi-line 'yes
|
|
:data (if filtered-articles
|
|
(str:join (crlf-string) (mapcar #'write-to-string filtered-articles))
|
|
""))))))))))))
|
|
|
|
(defun cmd-listgroup-old (r)
|
|
(with-auth
|
|
(let* ((args (request-args r))
|
|
(g (if args (car args) (client-group *client*))))
|
|
(cond
|
|
;; If no group is selected and no argument was provided...
|
|
((not g)
|
|
(make-response :code 412 :request r :data "must say GROUP first"))
|
|
;; When LISTGROUP takes at most one argument (the group name)...
|
|
((> (length args) 1)
|
|
(make-response :code 400 :request r :data "No, no: LISTGROUP takes at most one argument."))
|
|
(t
|
|
(with-group g r
|
|
(set-group! g)
|
|
(multiple-value-bind (low high len) (group-high-low g)
|
|
;; Fetch the list of article integers
|
|
(let ((articles (get-articles g low high)))
|
|
(setf (client-article *client*) low)
|
|
;; Prepend the 211 success line and format the multi-line response
|
|
(prepend-response-with (fmt "~a ~a ~a ~a article numbers follow" len low high g)
|
|
(make-response :code 211
|
|
:request r
|
|
:multi-line 'yes
|
|
:data (str:join (crlf-string)
|
|
(mapcar #'write-to-string articles))))))))))))
|
|
|
|
(defun cmd-help (r)
|
|
(labels ((menu (ls)
|
|
(loop for item in ls
|
|
collect (display-fn item)))
|
|
(display-fn (cmd-pair)
|
|
(let ((cmd (cdr cmd-pair)))
|
|
(fmt "~A ~A"
|
|
(command-verb cmd)
|
|
(command-description cmd)))))
|
|
(let ((lines (menu *commands-assoc*)))
|
|
(prepend-response-with
|
|
"What's on the menu today?"
|
|
(make-response :code 200 :multi-line 'yes
|
|
:request r
|
|
:data (str:join (crlf-string) lines))))))
|
|
|
|
(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
|
|
(nntp-date-command)))
|
|
|
|
(defun conforms-headers? (headers-str)
|
|
"HEADERS-STR is the raw header block (without the body).
|
|
Returns (values T NIL) on success, or (values NIL error-string)."
|
|
(let* ((headers (parse-headers headers-str))
|
|
(missing (loop for h in (headers-required-from-clients)
|
|
unless (lookup h headers)
|
|
collect h)))
|
|
(cond
|
|
(missing (article-syntax-error!
|
|
(fmt "missing the ~a ~a"
|
|
(str:join ", " (mapcar (lambda (h) (fmt "/~a/" h)) missing))
|
|
(word-plural (length missing) "header"))))
|
|
(t
|
|
(let ((ngs (newsgroups-header->list (get-header "newsgroups" headers)))
|
|
(ngs-dont-exist nil))
|
|
(dolist (g ngs)
|
|
(when (or (not (group-name-conforms? g))
|
|
(not (group? g)))
|
|
(push g ngs-dont-exist)))
|
|
(if (not (zerop (length ngs-dont-exist)))
|
|
(article-syntax-error! (fmt "the ~a ~a just ~a exist"
|
|
(word-plural (length ngs-dont-exist) "newsgroup")
|
|
(str:join ", " (sort ngs-dont-exist #'string<))
|
|
(word-plural (length ngs-dont-exist) "doesn't")))
|
|
(values t nil)))))))
|
|
|
|
(defun text/plain? (header-s)
|
|
;; I say T when S begins with "text/plain" or when S is "".
|
|
(let* ((s (str:collapse-whitespaces header-s))
|
|
(needle "text/plain")
|
|
(len (min (length needle) (length s))))
|
|
(or (zerop len)
|
|
(and (<= (length needle) (length s))
|
|
(string= needle s :end1 len :end2 len)))))
|
|
|
|
(defun headers-required-from-clients ()
|
|
'("from" "newsgroups" "subject" "message-id" "date"))
|
|
|
|
(defun suggest-message-id (&optional (n 20))
|
|
(fmt "<~a@loop>" (random-string n)))
|
|
|
|
(defun random-string (size)
|
|
(let* ((universe "abcdefghijklmnopqrstuvwxyz")
|
|
(len (length universe))
|
|
(state (make-random-state t))
|
|
mid)
|
|
(dotimes (c size)
|
|
(setq mid (cons (char universe (random len state)) mid)))
|
|
(coerce mid 'string)))
|
|
|
|
(defun cmd-post (r)
|
|
(with-auth
|
|
(send-response!
|
|
(make-response :code 340
|
|
:data (fmt "Okay, go ahead. Suggested message-id ~a." (suggest-message-id))))
|
|
(let ((tmp (fmt "tmp/post-~a.tmp" (random-string 12))))
|
|
(unwind-protect
|
|
(handler-case
|
|
(progn
|
|
(nntp-read-article-to-disk tmp)
|
|
(stderr "finished writing article to disk in ~a~%" tmp)
|
|
(let* ((headers-raw (read-headers-raw tmp))
|
|
(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)
|
|
(conforms-headers? headers-str) ;; raises a condition if it doesn't go well
|
|
(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 "linking finished~%")
|
|
(update-last-post-date! (client-username *client*))
|
|
(make-response :code 240 :request r :data "Thank you! Your article has been saved."))))
|
|
(article-syntax-error (c)
|
|
(make-response
|
|
:code 400 :request r
|
|
:data (fmt "Sorry. Your article doesn't conform: ~a." c)))
|
|
(already-seen-article (c)
|
|
(make-response :code 441 :request r :data (fmt "~a" c))))
|
|
(ignore-errors (delete-file tmp))))))
|
|
|
|
(defun newsgroups-header->list (s)
|
|
(mapcar #'(lambda (n) (str:trim (string-downcase n))) (str:split "," s)))
|
|
|
|
(defun update-last-post-date! (username)
|
|
(let ((u (get-account username)))
|
|
(setf (account-last-post u) (get-universal-time))))
|
|
|
|
(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-insist-old (g name src-path)
|
|
(loop for name from name do
|
|
(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)
|
|
(declare (ignore low len))
|
|
(1+ high)))
|
|
|
|
(defun nntp-read-article-to-disk (tmp-path)
|
|
"Streams an article to disk."
|
|
(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
|
|
;; 46 (#\.). LENGTH/ELT instead of EQUAL-against-a-list, since
|
|
;; NNTP-READ-LINE hands back a vector.
|
|
(and ls (not (eq ls :eof)) (= (length ls) 1) (= (elt ls 0) 46)))
|
|
|
|
(defun nntp-read-line-buffered (stream buffer)
|
|
(let* ((data (nntp-stream-buffer-data buffer))
|
|
(capacity (length data)))
|
|
(labels ((find-lf (start end)
|
|
(position 10 data :start start :end end))
|
|
(extract-line (lf-pos)
|
|
(let* ((start (nntp-stream-buffer-head buffer))
|
|
;; If the previous character is CR (13), strip it
|
|
(end-line (if (and (> lf-pos start) (= (aref data (1- lf-pos)) 13))
|
|
(1- lf-pos)
|
|
lf-pos))
|
|
(line (subseq data start end-line)))
|
|
(setf (nntp-stream-buffer-head buffer) (1+ lf-pos))
|
|
line))
|
|
(refill-and-extract-line ()
|
|
(let* ((head (nntp-stream-buffer-head buffer))
|
|
(tail (nntp-stream-buffer-tail buffer))
|
|
(remaining (- tail head)))
|
|
;; 1. Prevent buffer saturation/overflow
|
|
(when (= remaining capacity)
|
|
(stderr "line too long in the network buffer: [~A]" (subseq data head tail))
|
|
(error "no space left on the network buffer for the current line"))
|
|
|
|
;; 2. Shift remaining bytes to the start (fast memmove)
|
|
(when (> remaining 0)
|
|
(replace data data :start1 0 :start2 head :end2 tail))
|
|
(setf (nntp-stream-buffer-head buffer) 0)
|
|
(setf (nntp-stream-buffer-tail buffer) remaining)
|
|
|
|
;; 3. Fetch data via the unified dispatch mechanism
|
|
(let* ((n (fetch-more-bytes stream data remaining (- capacity remaining)))
|
|
(new-tail (+ remaining n)))
|
|
(setf (nntp-stream-buffer-tail buffer) new-tail)
|
|
(let ((lf-pos (find-lf remaining new-tail)))
|
|
(if lf-pos
|
|
(extract-line lf-pos)
|
|
(refill-and-extract-line)))))))
|
|
|
|
;; --- Main flow ---
|
|
(let ((lf-pos (find-lf (nntp-stream-buffer-head buffer) (nntp-stream-buffer-tail buffer))))
|
|
(if lf-pos
|
|
(extract-line lf-pos)
|
|
(refill-and-extract-line))))))
|
|
|
|
(defun fetch-more-bytes (stream buf start max-count)
|
|
"Try the fast POSIX path; fall back to a portable read-byte loop
|
|
when the stream has no underlying fd (Gray streams under SLIME,
|
|
string streams in tests, etc.)."
|
|
(handler-case (%unix-read stream buf start max-count)
|
|
(type-error ()
|
|
(%portable-read stream buf start max-count))))
|
|
|
|
(defun %portable-read (stream buf start max-count)
|
|
;; Blocks for the VERY FIRST byte to respect the wait-for-data contract,
|
|
;; preventing busy-waiting loops.
|
|
(let ((first-byte (read-byte stream nil :eof)))
|
|
(when (eq first-byte :eof)
|
|
(error 'end-of-file :stream stream))
|
|
(setf (aref buf start) first-byte)
|
|
|
|
;; Slurp any IMMEDIATELY available bytes to minimize looping overhead,
|
|
;; up to max-count. 'listen' returns T if a byte is ready on the wire.
|
|
(let ((count 1))
|
|
(loop while (and (< count max-count) (listen stream))
|
|
do (let ((b (read-byte stream nil :eof)))
|
|
(when (eq b :eof) (loop-finish))
|
|
(setf (aref buf (+ start count)) b)
|
|
(incf count)))
|
|
count)))
|
|
|
|
(defun %unix-read (stream buf start max-count)
|
|
;;; One POSIX read(2) on STREAM's underlying fd.
|
|
;;;
|
|
;;; Blocks until at least one byte arrives, then returns immediately with
|
|
;;; however many bytes the kernel has buffered (up to MAX-COUNT).
|
|
;;; Retries transparently on EINTR (signals can interrupt system calls).
|
|
;;; Signals END-OF-FILE when the peer closes the connection.
|
|
(let ((fd (sb-sys:fd-stream-fd (fd-stream-of stream))))
|
|
(sb-sys:with-pinned-objects (buf)
|
|
(loop
|
|
(multiple-value-bind (n err)
|
|
(sb-unix:unix-read fd
|
|
(sb-sys:sap+ (sb-sys:vector-sap buf) start)
|
|
max-count)
|
|
(cond
|
|
((and (null n) (= err sb-unix:eintr)))
|
|
((or (null n) (zerop n))
|
|
(error 'end-of-file :stream stream))
|
|
(t (return n))))))))
|
|
|
|
(defun fd-stream-of (stream)
|
|
"Peel away SYNONYM-STREAM and TWO-WAY-STREAM wrappers until we reach
|
|
the underlying FD-STREAM. Signals a clear error if no FD-STREAM is found."
|
|
(etypecase stream
|
|
(sb-sys:fd-stream stream)
|
|
(synonym-stream (fd-stream-of (symbol-value (synonym-stream-symbol stream))))
|
|
(two-way-stream (fd-stream-of (two-way-stream-input-stream stream)))))
|
|
|
|
(defun list->bytes (ls)
|
|
(mapcar #'data->bytes ls))
|
|
|
|
(defun vector->bytes (v)
|
|
(mapcar #'data->bytes (coerce v 'list)))
|
|
|
|
(defun data->bytes (d)
|
|
(etypecase d
|
|
(null nil)
|
|
(integer (list d))
|
|
(string (string->bytes d))
|
|
(cons (list->bytes d))
|
|
(vector (vector->bytes d))))
|
|
|
|
(defun add-crlf-between (ls-of-ls)
|
|
;; Add \r\n to each ``line''. Returns List-of Byte.
|
|
(mapcar #'(lambda (ls) (append ls (list 13 10))) ls-of-ls))
|
|
|
|
(defun string->bytes (s)
|
|
(map 'list #'char-code s))
|
|
|
|
(defun bytes->string (ls)
|
|
(map 'string #'code-char ls))
|
|
|
|
(defun cmd-create-group (r)
|
|
(with-n-args 1 r
|
|
(let ((g (string-downcase (car (request-args r)))))
|
|
(multiple-value-bind (okay? reason)
|
|
(group-name-conforms? g)
|
|
(if (not okay?)
|
|
(make-response :code 580 :request r
|
|
:data (fmt "group name does not conform: ~a" reason))
|
|
(progn
|
|
(multiple-value-bind (path created?)
|
|
(in-groups (ensure-directories-exist (concatenate 'string g "/")))
|
|
(declare (ignore created?))
|
|
(if (not path)
|
|
(make-response :code 581 :request r
|
|
:data (fmt "could not create group ~a"
|
|
(if (group? g)
|
|
"because it already exists"
|
|
"but we don't know why---sorry!")))
|
|
(progn
|
|
(notify-group-created g)
|
|
(make-response :code 280 :request r
|
|
:data (fmt "group ~a created" g)))))))))))
|
|
|
|
(defun group-name-conforms? (g)
|
|
(conforms-to? g "^[^\\s/]+$"))
|
|
|
|
(defun user-name-conforms? (u)
|
|
(conforms-to? u "^[^\\s]+$"))
|
|
|
|
(defun cmd-create-account (r)
|
|
(with-auth
|
|
(with-n-args 1 r
|
|
(let* ((args (mapcar #'str:upcase (request-args r)))
|
|
(username (car args)))
|
|
(multiple-value-bind (username pass-or-error)
|
|
(new-account! username (client-username *client*))
|
|
(if (not username)
|
|
(make-response :code 400 :request r
|
|
:data (fmt "~a. Choose a new name." pass-or-error))
|
|
(progn
|
|
(notify-user-created username)
|
|
(make-response :code 200 :request r
|
|
:data (fmt "Okay, account ~a created with password ``~a''."
|
|
username pass-or-error)))))))))
|
|
|
|
(defun read-accounts! ()
|
|
(let ((*package* (find-package '#:loop)))
|
|
(with-open-file
|
|
(s "accounts.lisp"
|
|
:direction :input)
|
|
(setq *accounts* (read s))))
|
|
*accounts*)
|
|
|
|
(defun string->array (s)
|
|
(make-array (length s)
|
|
:element-type '(unsigned-byte 8)
|
|
:initial-contents (map 'vector #'char-code s)))
|
|
|
|
(defun string->sha256 (s)
|
|
(let ((d (ironclad:make-digest :sha256)))
|
|
(ironclad:produce-digest (ironclad:update-digest d (string->array s)))))
|
|
|
|
(defun new-account! (username invited-by)
|
|
(let* ((u (str:upcase username))
|
|
(p (random-string 6))
|
|
(a (make-account :username u
|
|
:pass (string->sha256 (str:upcase p))
|
|
:creation (get-universal-time))))
|
|
(multiple-value-bind (okay? reason) (user-name-conforms? u)
|
|
(declare (ignore reason))
|
|
(cond ((not okay?)
|
|
(values nil (fmt "username must conform to ^[^\\s]+$")))
|
|
((get-account u)
|
|
(values nil (fmt "account ~a already exists" u)))
|
|
(t
|
|
(push u (account-friends (get-account invited-by)))
|
|
(push a *accounts*)
|
|
(write-accounts!)
|
|
(values (str:upcase username) p))))))
|
|
|
|
(defun write-accounts! ()
|
|
(with-file-lock ("accounts.lck")
|
|
(let ((name
|
|
(loop
|
|
(let* ((tmp (random-string 10))
|
|
(name (fmt "~a.tmp" tmp)))
|
|
(when (ignore-errors
|
|
(with-open-file (s name
|
|
:direction :output
|
|
:if-exists :error
|
|
:if-does-not-exist :create)
|
|
(write *accounts* :stream s)
|
|
t))
|
|
(return name))))))
|
|
(if (ignore-errors (rename-file name "accounts.lisp"))
|
|
(values t *accounts*)
|
|
(values nil (fmt "could not rename ~a to accounts.lisp" name))))))
|
|
|
|
(defun get-account (username)
|
|
(loop for u in *accounts*
|
|
do (when (string= (str:upcase username) (account-username u))
|
|
(return u))))
|
|
|
|
(defun cmd-unlock-account (r)
|
|
(with-auth
|
|
(with-n-args 1 r
|
|
(let* ((args (mapcar #'str:upcase (request-args r)))
|
|
(username (car args)))
|
|
(cond ((not (get-account username))
|
|
(make-response :code 400 :request r
|
|
:data (fmt "No such account ~a." username)))
|
|
((not (locked? username))
|
|
(make-response :code 400 :request r
|
|
:data (fmt "Can't unlock ~a because it's not locked." username)))
|
|
(t
|
|
(unlock-account! username)
|
|
(notify-user-unlocked username)
|
|
(make-response :code 200 :request r
|
|
:data (fmt "Okay, account ~a unlocked." username))))))))
|
|
|
|
(defun unlock-account! (username)
|
|
(let ((u (get-account username)))
|
|
(cond ((not u)
|
|
(values nil "no such account"))
|
|
((not (locked? username))
|
|
(values nil "account isn't locked"))
|
|
(t
|
|
(setf (account-pass u) (account-pass-locked u))
|
|
(setf (account-pass-locked u) nil)
|
|
(setf (account-pass-locked-why u) nil)))))
|
|
|
|
(defun cmd-login (r)
|
|
(let* ((args (mapcar #'str:upcase (request-args r))))
|
|
(cond
|
|
((not (= (length args) 2))
|
|
(bad-input r "Usage: login your-username your-password"))
|
|
(t
|
|
(multiple-value-bind (name pass) (apply #'values args)
|
|
(cond
|
|
((pass? name pass)
|
|
(log-user-in-as! name)
|
|
(make-response :code 200 :request r
|
|
:data (fmt "Welcome, ~a." name)))
|
|
(t (make-response :code 400 :request r
|
|
:data (fmt "Wrong password.")))))))))
|
|
|
|
(defun log-user-in-as! (name)
|
|
(setf (client-username *client*) name)
|
|
(log-user-in!))
|
|
|
|
(defun cmd-passwd (r)
|
|
(with-auth
|
|
(let* ((args (mapcar #'str:upcase (request-args r))))
|
|
(cond
|
|
((not (= (length args) 2))
|
|
(bad-input r "Usage: passwd current-password new-password"))
|
|
(t
|
|
(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)
|
|
(if okay?
|
|
(make-response :code 200 :request r
|
|
:data "You got it. Password changed.")
|
|
(make-response :code 500 :request r
|
|
:data (fmt "Sorry: ~a" problem)))))
|
|
(t (make-response :code 400 :request r
|
|
:data (fmt "Sorry. Wrong password."))))))))))
|
|
|
|
(defun pass? (username pass)
|
|
(let ((u (get-account username)))
|
|
(and
|
|
u
|
|
(cond ((null (account-pass u)) nil)
|
|
((integerp (account-pass u))
|
|
(eq (sxhash pass) (account-pass u)))
|
|
((arrayp (account-pass u))
|
|
(equalp (string->sha256 pass) (account-pass u)))
|
|
(t (error "pass? expected to find INTEGERP or ARRAYP but found ~a"
|
|
(type-of (account-pass u))))))))
|
|
|
|
(defun change-passwd! (username newpass)
|
|
(let ((u (get-account username)))
|
|
(when (not u)
|
|
(error "I could not find account ~a." username))
|
|
(setf (account-pass u) (string->sha256 (str:upcase newpass)))
|
|
(write-accounts!)))
|
|
|
|
(defun cmd-list-users (r)
|
|
(with-auth
|
|
(prepend-response-with
|
|
"List of current users:"
|
|
(make-response
|
|
:code 200 :request r :multi-line 'yes
|
|
:data (str:join (crlf-string) (list-users))))))
|
|
|
|
(defun size-of-longest-username ()
|
|
(loop for u in *accounts*
|
|
maximizing (length (account-username u))))
|
|
|
|
(defun list-users ()
|
|
(mapcar
|
|
#'(lambda (row) (cadr row))
|
|
(sort
|
|
(loop for u in *accounts*
|
|
collect (list
|
|
(account-username u)
|
|
(fmt "~v@a~a, ~a, invited ~a"
|
|
(size-of-longest-username)
|
|
(account-username u)
|
|
(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")
|
|
(or (account-friends u) "nobody"))))
|
|
#'string<= :key #'(lambda (row) (car row)))))
|
|
|
|
(defun universal-to-human (s)
|
|
(format-timestring
|
|
nil
|
|
(universal-to-timestamp s)
|
|
:format +asctime-format+))
|
|
|
|
(defun last-time-seen (username)
|
|
(let ((u (get-account username)))
|
|
(if u (let ((s (account-seen u)))
|
|
(if s (universal-to-human s))))))
|
|
|
|
(defun cmd-dd (r)
|
|
(make-response :code 200 :data (fmt "state: ~a" *client*) :request r))
|
|
|
|
(defun cmd-repl (r)
|
|
(if *enable-nntp-repl*
|
|
(with-auth
|
|
(repl r))
|
|
(make-response
|
|
:code 400
|
|
:data "The REPL has been *explicitly* disabled by the sysadmin. :("
|
|
:request r)))
|
|
|
|
(defun notify-group-created (g)
|
|
(post-notification
|
|
:subject (fmt "new group ~a by ~a" g (client-username *client*))
|
|
:body (fmt "Blame ~a for the group ~a just created." (client-username *client*) g)))
|
|
|
|
(defun notify-user-created (u)
|
|
(post-notification
|
|
:subject (fmt "new account ~a by ~a" u (client-username *client*))
|
|
:body (fmt "Blame ~a for inviting ~a." (client-username *client*) u)))
|
|
|
|
(defun notify-user-unlocked (u)
|
|
(let ((guilty (client-username *client*)))
|
|
(post-notification
|
|
:subject (fmt "account ~a unlocked by ~a" u guilty)
|
|
:body (fmt "Blame ~a for unlocking ~a." guilty u))))
|
|
|
|
(defun post-notification (&key subject body)
|
|
(in-groups (ensure-directories-exist "local.control.news/"))
|
|
(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
|
|
(clingon:make-option
|
|
:string
|
|
:description "creates a new account"
|
|
:long-name "create-account"
|
|
:key :create-account)
|
|
(clingon:make-option
|
|
:string
|
|
:description "changes password"
|
|
:long-name "change-passwd"
|
|
:key :change-passwd)
|
|
(clingon:make-option
|
|
:flag
|
|
:description "lists accounts"
|
|
:short-name #\l
|
|
:long-name "list-accounts"
|
|
:key :list-accounts)
|
|
(clingon:make-option
|
|
:flag
|
|
:description "runs a REPL right now"
|
|
:short-name #\r
|
|
:long-name "repl"
|
|
:key :repl)
|
|
(clingon:make-option
|
|
:flag
|
|
:description "disables the NNTP REPL"
|
|
:long-name "disable-nntp-repl"
|
|
:key :disable-nntp-repl)
|
|
(clingon:make-option
|
|
:flag
|
|
:description "logging (on stderr)"
|
|
:long-name "logging"
|
|
:key :logging)))
|
|
|
|
(defun cli/list-accounts ()
|
|
(println (str:join (crlf-string) (list-users))))
|
|
|
|
(defun cli/create-account (username args)
|
|
(let ((invited-by (car args)))
|
|
(cond ((null invited-by)
|
|
(println "Must specify who invites the new account."))
|
|
((get-account username)
|
|
(println "Username account ``~a'' already exists." username))
|
|
((not (get-account invited-by))
|
|
(println "Invited-by account ``~a'' doesn't exist." invited-by))
|
|
(t
|
|
(multiple-value-bind (okay? pass-or-error) (new-account! username invited-by)
|
|
(if okay?
|
|
(progn (println "Okay, account ``~a'' created with password ``~a''."
|
|
username pass-or-error)
|
|
(notify-user-created username))
|
|
(println "Sorry, ~a." pass-or-error)))))))
|
|
|
|
(defun cli/change-passwd (username args)
|
|
(let* ((random-passwd (random-string 6))
|
|
(given-passwd (car args))
|
|
(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)
|
|
(if okay?
|
|
(println "Okay, account ~a now has password ``~a''." username new-passwd)
|
|
(println "Sorry, could not change password: ~a." problem))))))
|
|
|
|
(defun cli/main-with-handlers (cmd)
|
|
(handler-case
|
|
(cli/main cmd)
|
|
(end-of-file ()
|
|
(print/finish "^D~%")
|
|
(uiop:quit 0))
|
|
(interactive-interrupt ()
|
|
(print/finish "^C~%")
|
|
(uiop:quit 0))))
|
|
|
|
(defun cli/main (cmd)
|
|
(read-accounts!)
|
|
(let ((args (clingon:command-arguments cmd))
|
|
(run-server t)
|
|
(repl (clingon:getopt cmd :repl))
|
|
(ca (clingon:getopt cmd :create-account))
|
|
(pa (clingon:getopt cmd :change-passwd))
|
|
(la (clingon:getopt cmd :list-accounts))
|
|
(logging (clingon:getopt cmd :logging))
|
|
(disable-nntp-repl (clingon:getopt cmd :disable-nntp-repl)))
|
|
(setf *debug* logging)
|
|
(when (or ca pa la)
|
|
(setf run-server nil))
|
|
(when la
|
|
(cli/list-accounts))
|
|
(when ca
|
|
(cli/create-account ca args))
|
|
(when pa
|
|
(cli/change-passwd pa args))
|
|
(when repl
|
|
(repl (make-request :verb "repl" :args '(command-line))))
|
|
(when disable-nntp-repl
|
|
(setq *enable-nntp-repl* nil))
|
|
(when run-server
|
|
(server-start))))
|
|
|
|
(defun cli/command ()
|
|
(clingon:make-command
|
|
:name "loop"
|
|
:description "An NNTP server for a circle of friends."
|
|
:version "0.0.1"
|
|
:license "GPL v3"
|
|
:options (cli/options)
|
|
:handler #'cli/main-with-handlers))
|
|
|
|
(defun main-loop ()
|
|
(handler-case
|
|
(loop
|
|
(let* ((bs (nntp-read-line))
|
|
(ln (bytes->string bs)))
|
|
(stderr "<<< ~a~%" ln)
|
|
(let ((r (send-response! (dispatch-line ln))))
|
|
(when (response-quit? r)
|
|
(return)))))
|
|
(end-of-file (c)
|
|
(declare (ignore c))
|
|
(stderr "a client disconnected with EOF~%"))
|
|
(error (e)
|
|
(stderr "fatal: ~A" e))))
|
|
|
|
(defun request-quit? (r) (and r (string= 'quit (request-verb r))))
|
|
|
|
(defun response-quit? (r) (and r (request-quit? (response-request r))))
|
|
|
|
(defun server-start ()
|
|
(set-up-tables!)
|
|
(send-banner!)
|
|
(main-loop))
|
|
|
|
(defun main ()
|
|
(let ((app (cli/command)))
|
|
(clingon:run app)))
|
|
|
|
(defun send-banner! ()
|
|
(send-response!
|
|
(make-response
|
|
:code 200
|
|
:data (welcome-message))))
|
|
|
|
(defun welcome-message ()
|
|
(cl-ppcre:regex-replace-all "HASH" "Welcome! I am LOOP 0.0.1 hash HASH. Say ``help'' for a menu." *git-hash*))
|
|
(setq lisp-unit:*print-failures* t)
|
|
(define-test dispatching
|
|
(assert-true (equalp (empty-response) (dispatch (make-request)))))
|
|
|
|
(defun unix->nntp (s)
|
|
"I substitute \n for \r\n"
|
|
(str:replace-all (fmt "~a" #\linefeed) (crlf-string) s))
|
|
|
|
(defvar a-post (unix->nntp "From: root
|
|
Message-id: <pwtdldytefplntosymvo@loop>
|
|
Subject: test
|
|
Newsgroups: local.test
|
|
|
|
Quickest test of the West.
|
|
"))
|
|
|
|
(defvar a-bad-post (unix->nntp "From: root
|
|
Message-id: <pwtdldytefplntosymvp@loop>
|
|
Subject: a bad test
|
|
Newsgroups: local.test, bad.newsgroup
|
|
|
|
A bad test from the biggest mouth of the south.
|
|
"))
|