1721 lines
65 KiB
Common Lisp
1721 lines
65 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* nil)
|
|
(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)
|
|
(defparameter *default-database* nil)
|
|
(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")
|
|
("NEXT" ,#'cmd-next "increments the article pointer")
|
|
("HELP" ,#'cmd-help "displays this menu")
|
|
("LIST" ,#'cmd-list "lists all groups")
|
|
("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")
|
|
("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 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 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=)))
|
|
(when (not w) (error "word not found"))
|
|
(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 enumerate (ls &optional (first-index 0))
|
|
(loop for e in ls and i from first-index
|
|
collect (cons i e)))
|
|
|
|
(defun ucs-2->ascii (bs)
|
|
;; I'm a Windows user.
|
|
#-win32 bs #+win32 (remove-if #'zerop bs))
|
|
|
|
(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 mkstr (&rest args) ;; a utility
|
|
(with-output-to-string (s)
|
|
(dolist (a args) (princ a s))))
|
|
|
|
(defun data (&rest args) ;; a utility
|
|
(flatten (map 'list #'data->bytes args)))
|
|
|
|
(defun crlf ()
|
|
(vector 13 10))
|
|
|
|
(defun crlf-string ()
|
|
(fmt "~c~c" #\return #\linefeed))
|
|
|
|
(defun flatten (obj)
|
|
(do* ((result (list obj))
|
|
(node result))
|
|
((null node) (delete nil result))
|
|
(cond ((consp (car node))
|
|
(when (cdar node) (push (cdar node) (cdr node)))
|
|
(setf (car node) (caar node)))
|
|
(t (setf node (cdr node))))))
|
|
|
|
(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 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 connect-index! (filename)
|
|
(setq *default-database* (clsql:connect (list filename) :database-type :sqlite3)))
|
|
|
|
(defun create-index! ()
|
|
(clsql:execute-command "create table if not exists indices
|
|
(id varchar(1000), grp varchar(1000), article varchar(300))")
|
|
(clsql:execute-command "create unique index if not exists idx_id_1
|
|
on indices (id)"))
|
|
|
|
(defun drop-create-index! ()
|
|
(clsql:execute-command "drop table if exists indices")
|
|
(create-index!))
|
|
|
|
(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 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)))))
|
|
(i (str:trim (pathname-name path)))
|
|
(m (str:trim (extract-mid (fetch-article g i)))))
|
|
(when (> (length m) 0)
|
|
(format t "article ~a/~a indexed by ~a~%" g i m)
|
|
(insert-index m g i)))))
|
|
|
|
(defun remake-index-from-fs ()
|
|
(drop-create-index!)
|
|
(index-from-fs!))
|
|
|
|
(defun parse-article (v)
|
|
(let ((pos (search #(13 10 13 10) v)))
|
|
(if pos
|
|
(make-article
|
|
:head (map 'string #'code-char (subseq v 0 pos))
|
|
:body (make-array (- (length v) (+ pos 4))
|
|
:element-type (array-element-type v)
|
|
:displaced-to v
|
|
:displaced-index-offset (+ pos 4)))
|
|
(make-article
|
|
:head (map 'string #'code-char v)
|
|
:body (make-array 0 :element-type (array-element-type v))))))
|
|
|
|
(defun hs-space-collapsed (hs)
|
|
(cl-ppcre:regex-replace-all (fmt "~a[ ~a]+" (crlf-string) #\tab) hs " "))
|
|
|
|
(defun hs-lines (lines) (str:split (crlf-string) lines))
|
|
|
|
(defun parse-header (header)
|
|
(let* ((h (str:collapse-whitespaces header))
|
|
(pos (search ":" h)))
|
|
(when (null pos)
|
|
(throw 'article-syntax-error
|
|
(values nil (fmt "missing colon in header |~a|" h))))
|
|
(when (<= (length h) (+ 2 pos))
|
|
(throw 'article-syntax-error
|
|
(values nil (fmt "empty header ~a" h))))
|
|
(multiple-value-bind (key val)
|
|
(values (subseq h 0 pos) (subseq h (+ 2 pos)))
|
|
(cons (str:downcase key) val))))
|
|
|
|
(defun parse-headers (hs)
|
|
(let ((ls (hs-lines (hs-space-collapsed hs))))
|
|
(mapcar #'(lambda (h) (parse-header h)) ls)))
|
|
|
|
(defun string-integer? (s) (ignore-errors (parse-integer s)))
|
|
|
|
(defun get-header (key hs)
|
|
(let ((pair (assoc key hs :test #'string=)))
|
|
(if pair (cdr pair) "")))
|
|
|
|
(defun fetch-headers (g i)
|
|
(let* ((a-string (fetch-article g i))
|
|
(a-parsed (parse-article a-string))
|
|
(headers (parse-headers (article-head a-parsed))))
|
|
(enrich-headers headers a-string a-parsed)))
|
|
|
|
(defun enrich-headers (hs a-raw a-parsed)
|
|
(append hs
|
|
`(("line-count" . ,(fmt "~a" (nlines (article-body a-parsed))))
|
|
("byte-count" . ,(fmt "~a" (length a-raw))))))
|
|
|
|
(defun nlines (v)
|
|
(loop for b across v
|
|
count (= b 10)))
|
|
|
|
(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 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 in (file-stream-payload-start-pos payload))
|
|
(let ((buf (make-array 8192 :element-type '(unsigned-byte 8)))
|
|
(at-line-start t)) ; The body implicitly starts at the beginning of a line
|
|
(loop for n = (read-sequence buf in)
|
|
while (plusp n)
|
|
do (loop for i from 0 below n
|
|
for byte = (aref buf i)
|
|
do (when (and at-line-start (= byte 46)) ; 46 is '.'
|
|
(write-byte 46 out-stream))
|
|
(write-byte byte out-stream)
|
|
(setf at-line-start (= byte 10)))))))
|
|
|
|
(defun 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 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-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-name)
|
|
(with-auth
|
|
(with-group-set
|
|
(let ((args (request-args r)))
|
|
(cond ((null args)
|
|
(funcall fn-name r (client-group *client*) (client-article *client*)))
|
|
((= 1 (length args))
|
|
(let* ((n-or-mid (car args)))
|
|
(cond ((string-integer? n-or-mid)
|
|
(funcall fn-name r (client-group *client*) n-or-mid))
|
|
(t (multiple-value-bind (group n-str) (lookup-index n-or-mid)
|
|
(if (and group n-str)
|
|
(funcall fn-name r group n-str)
|
|
(bad-input r (fmt "Unknown article ~a." 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))
|
|
|
|
(defun cmd-body (r)
|
|
(typical-cmd-head-body-article r #'body-response))
|
|
|
|
(defun cmd-article (r)
|
|
(typical-cmd-head-body-article r #'article-response))
|
|
|
|
(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 typical-cmd-response (code r g i requested-part)
|
|
(handler-case
|
|
(let* ((path (fmt "groups/~a/~a" g i))
|
|
(headers-raw (read-headers-raw path)))
|
|
(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))
|
|
(payload
|
|
(ecase requested-part
|
|
(:head (article-head a))
|
|
(:body (make-file-stream-payload :path path :start-pos header-length))
|
|
(:article (list (article-head a)
|
|
(crlf)
|
|
(crlf)
|
|
(make-file-stream-payload :path path :start-pos header-length))))))
|
|
(prepend-response-with (fmt "~a ~a" i mid)
|
|
(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)))
|
|
(stderr msg)
|
|
(make-response :code 400 :request r :data msg)))
|
|
(error (c)
|
|
(let ((msg (fmt "unexpected condition when reading article ~a/~a: ~a" g i c)))
|
|
(stderr msg)
|
|
(make-response :code 400 :request r :data msg)))))
|
|
|
|
(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 (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" "line-count" "byte-count"))
|
|
|
|
(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)
|
|
(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 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? (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 ;; 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))))))
|
|
(sort (remove-if-not
|
|
#'(lambda (x) (between? x (or from x) (or to x)))
|
|
as)
|
|
#'<))))
|
|
|
|
(defun group-high-low (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 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 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 cmd-date (r)
|
|
(make-response :code 201
|
|
:request r
|
|
:data
|
|
(format-timestring nil (now))))
|
|
|
|
(defun conforms? (bs)
|
|
"Convenience wrapper: parse the in-memory article and check headers."
|
|
(catch 'article-syntax-error
|
|
(conforms-headers?
|
|
(article-head (parse-article bs)))))
|
|
|
|
(defun conforms-headers? (headers-str)
|
|
"HEADERS-STR is the raw header block (without the body).
|
|
Returns (values T NIL) on success, or (values NIL error-string)."
|
|
(catch 'article-syntax-error
|
|
(let ((headers (parse-headers headers-str)))
|
|
(let ((result (dolist (h (headers-required-from-clients))
|
|
(when (not (lookup h headers))
|
|
(return (fmt "missing the /~a/ header" h))))))
|
|
(cond
|
|
((stringp result) (values nil result))
|
|
(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)))
|
|
(values nil (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"))
|
|
|
|
(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 unparse-article (parsed)
|
|
;; 1. Build the new headers as a standard string
|
|
(let* ((headers-str (with-output-to-string (s)
|
|
(dolist (h (parse-headers (article-head parsed)))
|
|
(format s "~a: ~a~c~c" (str:capitalize (car h)) (cdr h) #\return #\linefeed))
|
|
;; Add the final \r\n separating headers from the body
|
|
(format s "~c~c" #\return #\linefeed)))
|
|
;; 2. Convert the string to a small byte array (~1 KB)
|
|
(headers-bytes (make-array (length headers-str)
|
|
:element-type '(unsigned-byte 8)
|
|
:initial-contents (map 'list #'char-code headers-str)))
|
|
;; 3. Get the displaced, zero-copy body array
|
|
(body-bytes (article-body parsed)))
|
|
(concatenate '(vector (unsigned-byte 8)) headers-bytes body-bytes)))
|
|
|
|
(defun ensure-header (h fn bs)
|
|
(let* ((headers (parse-headers (article-head (parse-article bs)))))
|
|
(if (lookup h headers)
|
|
bs
|
|
(unparse-article
|
|
(make-article
|
|
:head
|
|
(str:join (crlf-string)
|
|
(mapcar #'(lambda (h)
|
|
(fmt "~a: ~a" (car h) (cdr h)))
|
|
(cons (cons h (funcall fn)) headers)))
|
|
:body (article-body (parse-article bs)))))))
|
|
|
|
(defun get-date ()
|
|
(multiple-value-bind (s m h day mon year dow dst-p tz)
|
|
(get-decoded-time)
|
|
(declare (ignore dow dst-p))
|
|
(fmt "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d GMT~a"
|
|
year mon day h m s (- tz))))
|
|
|
|
(defun ensure-mid (bs)
|
|
(ensure-header "message-id" #'suggest-message-id bs))
|
|
|
|
(defun ensure-date (bs)
|
|
(ensure-header "date" #'get-date bs))
|
|
|
|
(defun cmd-post (r)
|
|
(with-auth
|
|
(let ((suggested (suggest-message-id)))
|
|
(send-response!
|
|
(make-response
|
|
:code 340
|
|
:data (fmt "Okay, go ahead. Suggested message-id ~a." suggested)))
|
|
(let ((tmp (fmt "post-~a.tmp" (random-string 12))))
|
|
(unwind-protect
|
|
(progn
|
|
(in-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)))
|
|
;; 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))))))
|
|
(stderr "finished reading the headers of the tmp file~%")
|
|
(stderr "headers string: ~a~%" headers-str)
|
|
(multiple-value-bind (okay? error) (conforms-headers? headers-str)
|
|
(cond
|
|
((not okay?)
|
|
(make-response
|
|
:code 400 :request r
|
|
:data (fmt "Sorry. Your article doesn't conform: ~a." error)))
|
|
(t
|
|
(multiple-value-bind (code reply)
|
|
(post tmp headers-raw)
|
|
(stderr "I'd post this article now.~%")
|
|
(update-last-post-date! (client-username *client*))
|
|
(make-response :code code :request r :data reply)))))))
|
|
(ignore-errors (delete-file tmp)))))))
|
|
|
|
(defun post (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)))
|
|
|
|
(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-try (name-try src-path)
|
|
(stderr "going to try to save ~a with name ~a~%" src-path name-try)
|
|
(let ((name (fmt "~a" name-try))
|
|
(tmp (fmt "~a.tmp" name-try)))
|
|
(with-open-file
|
|
(s name
|
|
:direction :output
|
|
:if-exists nil ; atomic O_EXCL allocation
|
|
:if-does-not-exist :create)
|
|
(when (null s)
|
|
(stderr "warning: save-article-try: ~a exists~%" name)
|
|
(return-from save-article-try '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.
|
|
(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)))
|
|
|
|
(defun save-article-insist (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))))))
|
|
|
|
(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."
|
|
(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)))
|
|
;(stderr "read line: ~a~%" 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)))))
|
|
|
|
(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))))))
|
|
|
|
(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
|
|
(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/"))
|
|
(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))))))
|
|
|
|
(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!)
|
|
(connect-index! "message-id.db")
|
|
(create-index!)
|
|
(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)))
|
|
(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.
|
|
"))
|