;;; -*- 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") ("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 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 insert-index (m g i) (handler-case (clsql:insert-records :into "indices" :attributes '(id grp article) :values (list (str:trim m) (str:trim g) (str:trim i))) (clsql-sys:sql-database-data-error (c) (cond ((= (slot-value c 'clsql-sys::error-id) 19) 'already-indexed) (t ; We should log this error. ;(format t "other error: ~a" (slot-value c 'clsql-sys::database-message)) 'sql-error))) (:no-error () nil))) (defun lookup-index (mid) (let* ((found (clsql:select [grp] [article] :from [indices] :where [= [id] (str:trim mid)])) (article (first found)) (grp (first article)) (art (second article))) (when found (values grp art)))) (defun remove-inactive-users! () (loop for u in *accounts* do (let ((username (account-username u))) (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) (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" "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 (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))) ;; 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!) (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) ;; for logging (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: Subject: test Newsgroups: local.test Quickest test of the West. ")) (defvar a-bad-post (unix->nntp "From: root Message-id: Subject: a bad test Newsgroups: local.test, bad.newsgroup A bad test from the biggest mouth of the south. "))