diff --git a/Anyfile b/Anyfile new file mode 100644 index 0000000..de15135 --- /dev/null +++ b/Anyfile @@ -0,0 +1,67 @@ +# -*- mode: makefile -*- +include Makefile + +default: all + +all: loop.exe loop.lisp loop.asd scripts/build-exe.lisp \ +scripts/build-index-from-fs.lisp \ +scripts/cron-remove-inactive-users.lisp \ +scripts/migrate-add-creation-date.lisp + +loop.exe: scripts/build-exe.lisp loop.lisp loop.asd + sbcl --script scripts/build-exe.lisp + (test -f loop.exe && cmp loop loop.exe) || cp loop loop.exe + +loop.lisp: loop.nw + ./make-release $$(git log --oneline | head -1 | awk '{print $$1}') \ + loop.nw > loop.tmp && mv loop.tmp loop.nw + (any tangle -Rloop.lisp < loop.nw | sh format-def | \ + dos2unix > loop.tmp || \ + (rm loop.tmp && exit 1)) && \ + mv loop.tmp loop.lisp + +loop.asd: loop.nw + (any tangle -Rloop.asd < loop.nw | dos2unix > loop-asd.tmp || \ + (rm loop-asd.tmp && exit 1)) && \ + mv loop-asd.tmp loop.asd + +scripts/build-exe.lisp: loop.asd loop.lisp loop.nw + (any tangle -Rbuild-exe.lisp < loop.nw | dos2unix > build-exe.tmp || \ + (rm build-exe.tmp && exit 1)) && \ + mv build-exe.tmp scripts/build-exe.lisp + +scripts/build-index-from-fs.lisp: loop.nw + (any tangle -Rbuild-index-from-fs.lisp < loop.nw | dos2unix > \ + build-index-from-fs.tmp || \ + (rm build-index-from-fs.tmp && exit 1)) && \ + mv build-index-from-fs.tmp scripts/build-index-from-fs.lisp + +scripts/cron-remove-inactive-users.lisp: loop.nw + (any tangle -Rcron-remove-inactive-users.lisp < loop.nw | dos2unix > \ + cron-remove-inactive-users.tmp || \ + (rm cron-remove-inactive-users.tmp && exit 1)) && \ + mv cron-remove-inactive-users.tmp \ + scripts/cron-remove-inactive-users.lisp + +scripts/migrate-add-creation-date.lisp: loop.nw + (any tangle -Rmigrate-add-creation-date.lisp < loop.nw | dos2unix > \ + migrate-add-creation-date.tmp || \ + (rm migrate-add-creation-date.tmp && exit 1)) && \ + mv migrate-add-creation-date.tmp \ + scripts/migrate-add-creation-date.lisp + +run: loop.nw + (any tangle -Rrun < loop.nw | dos2unix > run.tmp || \ + (rm run.tmp && exit 1)) && \ + mv run.tmp run && \ + chmod 0755 run + +loop.tex: loop.nw + any weave -delay -index loop.nw | dos2unix > loop.tex + +loop.pdf: loop.tex + latexmk -pdf loop + +clean: + rm -f loop loop.exe loop.asd loop.lisp loop.tex loop.pdf \ + *.fasl *.db .*~ *~ *.out *.aux *.log *.fls *.fdb_latexmk diff --git a/format-def b/format-def new file mode 100644 index 0000000..af80142 --- /dev/null +++ b/format-def @@ -0,0 +1,27 @@ +#!/bin/sh +usage() +{ + printf 'usage: %s [file.lisp]\n' $0 + exit 1 +} +## The first program finds certain definitions and inserts a new blank +## line *before* the definition. Such action makes function +## definitions separated by two blank lines in some cases. We then +## remove the excess with the second program. Notice we need the -E +## option because we're using the | metacharacter that is only +## supported by popular sed programs with the -E option. This +## violates POSIX sed, but keep in mind that we only run this when +## releasing the package. This is a building tool, not part of the +## service. +sed -E '/^\(defun |\(defmacro /{ + i\ + +}' $* | sed '/^[ \t]*$/{ + N + /^[ \t]*\n$/D +}' +## We first find a blank line. Then we say N to expand the pattern +## space to include the next line. Then we delete the *first* blank +## line and not the second---that's what the D command does. This +## strategy is explained by Dale Dougherty and Arnold Robbins in ``sed +## & awk'' second edition, pages 112--114. diff --git a/loop.asd b/loop.asd index 5793792..ec22d5d 100644 --- a/loop.asd +++ b/loop.asd @@ -1,6 +1,6 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*- -(asdf:defsystem :loop - :version "0.1" +(asdf:defsystem :LOOP + :version "9575ac2" :description "An NNTP server for a circle of friends." :depends-on (:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon :filesystem-utils :ironclad/digest/sha256) diff --git a/loop.lisp b/loop.lisp index 1d58789..88e0b82 100644 --- a/loop.lisp +++ b/loop.lisp @@ -30,6 +30,7 @@ (defparameter *months-inactive-allowed* 3) (defparameter *months-never-logged-in* 1) (defvar *debug* nil) + (defun table-of-commands () `(("GROUP" ,#'cmd-group "sets the current group") ("NEXT" ,#'cmd-next "increments the article pointer") @@ -80,6 +81,7 @@ :verb 'unrecognized :description "a command for all commands typed wrong"))) (or (cdr cmd) (unrecognized-command))))) + (defmacro in-dir (dir &rest body) `(let ((*default-pathname-defaults* (truename ,dir))) (uiop:with-current-directory (,dir) @@ -187,6 +189,7 @@ (defmacro mac (&rest body) `(macroexpand-1 ,@body)) + (defun repl (r) (in-package :loop) (loop @@ -216,13 +219,16 @@ "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 (data message (crlf) (response-data r)) :multi-line (response-multi-line r) :request (response-request r))) + (defun append-crlf-if-needed (seq) (cond ((stringp seq) @@ -244,10 +250,12 @@ (stderr ">>> ~a" (bytes->string (ucs-2->ascii bs))))) (force-output) r) + (defun my-write (ls-of-bytes s) (if (interactive-stream-p s) (write-sequence (mapcar #'code-char ls-of-bytes) s) (write-sequence ls-of-bytes s))) + (defun parse-request (r) (let* ((collapsed-s (str:collapse-whitespaces (request-said r))) (ls (str:split " " collapsed-s :omit-nulls 'please))) @@ -258,6 +266,7 @@ (make-request :said (request-said r) :verb (str:upcase verb) :args args)))))) + (defun insert-index (m g i) (handler-case (clsql:insert-records @@ -283,6 +292,7 @@ (art (second article))) (when found (values grp art)))) + (defun connect-index! (filename) (setq *default-database* (clsql:connect (list filename) :database-type :sqlite3))) @@ -295,6 +305,7 @@ (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))) @@ -319,6 +330,7 @@ (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) @@ -332,6 +344,7 @@ (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))) @@ -382,6 +395,7 @@ (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)) @@ -392,6 +406,7 @@ (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))) @@ -410,6 +425,7 @@ 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))))) @@ -422,6 +438,7 @@ (defun remake-index-from-fs () (drop-create-index!) (index-from-fs!)) + (defun parse-article (v) (let ((parts (split-vector (vector 13 10 13 10) v nil :limit 2))) (make-article :headers (map 'string #'code-char (car parts)) :body (cadr parts)))) @@ -449,6 +466,7 @@ (mapcar #'(lambda (h) (parse-header h)) ls))) (defun string-integer? (s) (ignore-errors (parse-integer s))) + (defun get-header-from-article (h a) (get-header h (parse-headers (article-headers (parse-article a))))) @@ -468,6 +486,7 @@ ("byte-count" . ,(format nil "~a" (length a)))))) (defun nlines (v) (length (split-vector (crlf) v nil))) + (defun fetch-article (g i) (in-groups (read-file-raw (format nil "~a/~a" g i)))) @@ -485,11 +504,15 @@ (defun fetch-body (g i) (article-body (parse-article (fetch-article g i)))) + (defun encode-body (a) a) + (defun extract-mid (a) (lookup "message-id" (parse-headers (article-headers (parse-article a))))) + (defun lookup (key table) (cdr (assoc key table :test #'string=))) + (defun dispatch (r) (let* ((verb (request-verb r))) (if (null verb) @@ -498,6 +521,7 @@ (defun dispatch-line (ln) (dispatch (parse-request (make-request :said ln)))) + (defun cmd-authinfo (r) (let* ((args (mapcar #'str:upcase (request-args r)))) (cond @@ -531,8 +555,10 @@ (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 @@ -551,17 +577,22 @@ (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 #'(lambda (a) (encode-body a)))) + (defun head-response (r g i) (typical-cmd-response 221 r g i #'(lambda (a) (article-headers (parse-article a))))) + (defun body-response (r g i) (typical-cmd-response 222 r g i #'(lambda (a) (encode-body (article-body (parse-article a)))))) + (defun typical-cmd-response (code r g i get-data) (handler-case (let ((a (fetch-article g i))) @@ -578,6 +609,7 @@ (make-response :code 400 :request r :data (format nil "article ~a/~a: ~a" g i c))))) + (defun cmd-next (r) (with-auth (let ((g (client-group *client*)) @@ -598,6 +630,7 @@ (defun mid-by-name (g name) (extract-mid (fetch-article g name))) + (defun cmd-xover (r) (with-auth (with-group-set @@ -638,13 +671,16 @@ (member (car h) (xover-headers) :test #'string=)) (fetch-headers g i))))))))))) + (defun xover-format-line (i hs) (str:concat (format nil "~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 @@ -715,7 +751,7 @@ #+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)) @@ -776,11 +812,13 @@ #'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) (let ((lines (menu *commands-assoc*))) (prepend-response-with @@ -788,6 +826,7 @@ (make-response :code 200 :multi-line 'yes :request r :data (str:join (crlf-string) lines))))) + (defun menu (ls) (if (null ls) nil @@ -798,13 +837,16 @@ (format nil "~A ~A" (command-verb cmd) (command-description cmd)))) + (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 ;; parse-headers might throw (let ((headers (parse-headers (article-headers (parse-article bs))))) @@ -829,6 +871,7 @@ (defun headers-required-from-clients () '("from" "newsgroups" "subject")) + (defun suggest-message-id (&optional (n 20)) (format nil "<~a@loop>" (random-string n))) @@ -840,6 +883,7 @@ (dotimes (c size) (setq mid (cons (char universe (random len state)) mid))) (coerce mid 'string))) + (defun unparse-article (parsed) (data (let ((ls)) @@ -848,6 +892,7 @@ (nreverse ls)) (crlf) (article-body parsed))) + (defun ensure-header (h fn bs) (let* ((headers (parse-headers (article-headers (parse-article bs))))) (if (lookup h headers) @@ -870,8 +915,10 @@ (defun ensure-mid (bs) (ensure-header "message-id" #'suggest-message-id bs)) + (defun ensure-date (bs) (ensure-header "date" #'get-date bs)) + (defun newsgroups-header->list (s) (mapcar (lambda (n) (str:trim (string-downcase n))) (str:split "," s))) @@ -910,9 +957,11 @@ (data " However, the groups " (str:join ", " (sort ngs-dont-exist #'string<)) " just don't exist."))))))) + (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 old (make-pathname :name new :type :unspecific))) @@ -936,6 +985,7 @@ :element-type '(unsigned-byte 8)) (write-sequence bs s)) (rename-no-extension tmp name))) + (defun save-article-insist (g name a message-id) (loop for name from name do (in-dir (format nil "groups/~a/" g) @@ -946,12 +996,14 @@ (multiple-value-bind (low high len) (group-high-low g) (declare (ignore low len)) (1+ high))) + (defun nntp-read-article (&optional acc) ;; Returns List-of Byte. (let* ((ls (ucs-2->ascii (nntp-read-line)))) (cond ;; 46 == (byte #\.) ((equal (list 46) ls) (flatten (add-crlf-between acc))) (t (nntp-read-article (append acc (list ls))))))) + (defun nntp-read-line (&optional (s *standard-input*) acc) ;; Returns List-of Byte. (let ((x (read-byte s))) @@ -984,6 +1036,7 @@ (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))))) @@ -1012,6 +1065,7 @@ (if okay? (values t nil) (values nil "must match ^([a-z0-9]+)")))) + (defun cmd-create-account (r) (with-auth (with-n-args 1 r @@ -1026,6 +1080,7 @@ (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 @@ -1056,6 +1111,7 @@ (push a *accounts*) (write-accounts!) (values (str:upcase username) p))))) + (defun write-accounts! () (let ((name (loop @@ -1078,6 +1134,7 @@ (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 @@ -1105,6 +1162,7 @@ (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 @@ -1123,6 +1181,7 @@ (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)))) @@ -1200,8 +1259,10 @@ (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 (format nil "state: ~a" *client*) :request r)) + (defun cmd-repl (r) (with-auth (repl r))) @@ -1268,6 +1329,7 @@ :description "logging (on stderr)" :long-name "logging" :key :logging))) + (defun cli/list-accounts () (println (str:join (crlf-string) (list-users)))) @@ -1297,6 +1359,7 @@ (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) @@ -1333,7 +1396,7 @@ (clingon:make-command :name "loop" :description "An NNTP server for a circle of friends." - :version "0.1" + :version "9575ac2" :license "GPL v3" :options (cli/options) :handler #'cli/main-with-handlers)) @@ -1347,6 +1410,7 @@ (return)))))) (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 () @@ -1360,7 +1424,9 @@ (defun send-banner! () (send-response! - (make-response :code 200 :data "Welcome! Say ``help'' for a menu."))) + (make-response + :code 200 + :data "Welcome! I am LOOP 9575ac2. Say ``help'' for a menu."))) (setq lisp-unit:*print-failures* t) (define-test first-test-of-the-west diff --git a/loop.nw b/loop.nw index 9188744..558aec0 100644 --- a/loop.nw +++ b/loop.nw @@ -323,6 +323,7 @@ Section~\ref{sec:repl}. Commands such as [[CREATE-ACCOUNT]], users need to know how to use {\tt nc} or {\tt telnet} to take advantage of all of \lp's capabilities. + \section{NNTP protocol} An Internet protocol is usually defined by a document whose tradition @@ -432,18 +433,6 @@ line, which is what causes that 400 response. (str:replace-all (string #\linefeed) " " (fmt "~a" c)))))))) @ %def repl -\section{Description of the package} - -<>= -An NNTP server for a circle of friends. -@ - -<>= -0.1 -@ - -These chunks are used in [[loop.asd]]. - \section{Representation of a client} How do we represent a client? A client is typically reading a group @@ -601,25 +590,6 @@ else should we handle this? (write-sequence ls-of-bytes s))) @ %def my-write -\section{Parsing of requests} - -The commands themselves we call {\tt verbs} and everything else the -user types we call {\tt args}. Observe that upper and lower case -letters are equivalent in request verbs. - -<>= -(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)))))) -@ %def parse-request - \section{Main loop} Every command consumes a [[request]] and produces a [[response]]. If @@ -657,9 +627,59 @@ itself---so we can cascade actions based on a user's request. (defun send-banner! () (send-response! - (make-response :code 200 :data "Welcome! Say ``help'' for a menu."))) + (make-response + :code 200 + :data "<>"))) @ %def main main-loop +\noindent It's always useful to know which version exactly we're +dealing with: +% +\begin{verbatim} +%./loop.exe +200 Welcome! I am LOOP 9575ac2. Say ``help'' for a menu. +\end{verbatim} +% +So we put a release tag on \lp's banner. + +<>= +Welcome! I am <> <>. Say ``help'' for a menu. +@ + +\noindent We take the opportunity and describe \lp's package, +information which we also use in [[loop.asd]]. + +<>= +LOOP +@ + +<>= +An NNTP server for a circle of friends. +@ + +<>= +9575ac2 +@ + +\section{Parsing of requests} + +The commands themselves we call {\tt verbs} and everything else the +user types we call {\tt args}. Observe that upper and lower case +letters are equivalent in request verbs. + +<>= +(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)))))) +@ %def parse-request + \section{Parsing of command-line arguments} We're using the clingon library as per Vincent Dardel suggestion in @@ -2804,7 +2824,7 @@ The \lp\ system definition: <>= ;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*- -(asdf:defsystem :loop +(asdf:defsystem :<> :version "<>" :description "<>" :depends-on (<>) diff --git a/make-release b/make-release new file mode 100644 index 0000000..1fb1af5 --- /dev/null +++ b/make-release @@ -0,0 +1,14 @@ +#!/bin/sh +usage() +{ + printf 'usage: %s tag file\n' $0 + exit 1 +} +test $# '<' 2 && usage +tag="$1" +shift +sed "/<>=/ { + n; + c\\ +$tag +}" $*