From efa5ee3ccde87259944d241ea83d8ab07853d136 Mon Sep 17 00:00:00 2001 From: Circling Skies Date: Tue, 9 Jun 2026 23:15:44 -0300 Subject: [PATCH] Uses polymode in the GNU EMACS, not noweb-mode any longer. --- Anyfile | 40 +++--- loop.lisp | 48 ++++--- loop.nw | 371 ++++++++++++++++++++++++++++-------------------------- 3 files changed, 239 insertions(+), 220 deletions(-) diff --git a/Anyfile b/Anyfile index 8fbd929..83a2ea4 100644 --- a/Anyfile +++ b/Anyfile @@ -6,27 +6,28 @@ 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 +scripts/migrate-add-creation-date.lisp \ +tags + +tags: loop.nw loop.lisp + etags --language=lisp loop.lisp loop.exe: scripts/build-exe.lisp loop.lisp loop.asd loop.nw sbcl --script scripts/build-exe.lisp (test -f loop.exe && cmp loop loop.exe) || cp loop loop.exe loop.lisp: loop.nw format-def - (any tangle -Rloop.lisp < loop.nw | sh format-def | \ - dos2unix > loop.tmp || \ + (no tangle -Rloop.lisp < loop.nw | sh format-def > loop.tmp || \ (rm loop.tmp && exit 1)) && \ mv loop.tmp loop.lisp format-def: loop.nw - (any tangle -Rformat-def < loop.nw | \ - dos2unix > format-def.tmp || \ + (no tangle -Rformat-def.sh < loop.nw > format-def.tmp || \ (rm format-def.tmp && exit 1)) && \ mv format-def.tmp format-def make-release: loop.nw - (any tangle -Rmake-release < loop.nw | \ - dos2unix > make-release.tmp || \ + (no tangle -Rmake-release.sh < loop.nw > make-release.tmp || \ (rm make-release.tmp && exit 1)) && \ mv make-release.tmp make-release @@ -35,47 +36,48 @@ release: make-release loop.nw > loop.tmp && mv loop.tmp loop.nw loop.asd: loop.nw - (any tangle -Rloop.asd < loop.nw | dos2unix > loop-asd.tmp || \ + (no tangle -Rloop.asd < loop.nw > 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 || \ + (no tangle -Rbuild-exe.lisp < loop.nw > 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 > \ + (no tangle -Rbuild-index-from-fs.lisp < loop.nw > \ 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 > \ + (no tangle -Rcron-remove-inactive-users.lisp < loop.nw > \ 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 > \ + (no tangle -Rmigrate-add-creation-date.lisp < loop.nw > \ 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 +# run: loop.nw +# (no tangle -Rrun < loop.nw > 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 + no weave -delay -index loop.nw > 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 + *.fasl *.db .*~ *~ *.out *.aux *.log *.fls *.fdb_latexmk \ + TAGS diff --git a/loop.lisp b/loop.lisp index bb7543a..45dbaee 100644 --- a/loop.lisp +++ b/loop.lisp @@ -620,9 +620,16 @@ (make-response :multi-line 'yes :code code :request r :data (funcall get-data a)))))) (sb-posix:syscall-error (c) - (make-response - :code 400 :request r - :data (format nil "article ~a/~a: ~a" g i c))))) + (let ((msg (format nil "article ~a/~a: ~a" g i c))) + (stderr msg) + (make-response + :code 400 :request r :data msg))) + (error (c) + (let ((msg (format nil "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 @@ -1251,23 +1258,24 @@ maximizing (length (account-username u)))) (defun list-users () - (read-accounts!) - (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))))) + (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 diff --git a/loop.nw b/loop.nw index 60ef8df..35f9132 100644 --- a/loop.nw +++ b/loop.nw @@ -1,4 +1,7 @@ -% -*- mode: noweb; noweb-default-code-mode: lisp-mode; -*- +% -*- mode: poly-noweb; -*- +% HELLO +%% %% % -*- mode: noweb; -*- +%% %% %% noweb-default-code-mode: lisp-mode; \documentclass[a4paper,11pt]{article} \usepackage[text={6.75in,10in},centering]{geometry} @@ -71,9 +74,9 @@ we write an e-mail to various friends to discuss a certain subject, we form a circle. When we decide to add another person to this quickly-made conference by e-mail, sometimes we use a well-known idiom---``adding John to the loop''. We add John's e-mail address to -the list of destinaries. So long as everyone replies to everyone, -John, too, will start getting all the messages. If anyone violates -this rule of replying to everyone involved, the loop is broken. +the list of destinataries. So long as everyone replies to everyone, +John too will get all the messages. If anyone violates this rule of +replying to everyone involved, the loop is broken. \begin{figure}[!htb] \centering \includegraphics[width=0.8\linewidth]{images/gnus-summary.png} @@ -98,7 +101,7 @@ For example, after John has been added to the loop, he is not able to leave by his own account. He needs to ask everyone involved to stop writing to him. This is usually easy to do, but instead people tend to ask for more technology such as mailing lists. A mailing list is -nothing by an automated version of this idea of writing to various +nothing but an automated version of this idea of writing to various people at once. When the mailing address is written to, a program resends the message to all subscribers of the mailing list and, this way, the conference takes place. @@ -107,29 +110,30 @@ But \lp\ has nothing to do with e-mail. \Lp\ uses a communication strategy---called a ``protocol''---that is even older than the web itself. The web started out around 1989--1990 and the protocol \lp\ uses begins its history in 1979, the year in which AT\&T released -UNIX V7, which was UUCP-ready, an acronym that stands for for UNIX to -UNIX copy. It's both a protocol and a set of programs for copying -files between UNIX systems. People begun exchanging messages by -copying files between machines. The idea eventually evolved into a -protocol called NNTP---Network News Transfer Protocol---, which is the -protocol used by \lp. (The protocol used to be called Netnews -Transfer Protocol.) Since e-mail was already daily practice of -members of the Internet back then, many things from e-mail were taken -by the NNTP designers. So, an NNTP message looks a lot like an e-mail -message and the two---NNTP and SMTP (the protocol used by -e-mail)---can often mingle seamlessly. The impression we get from -using NNTP is that we're sending e-mail to a certain group of people. -It's as though the message goes into a collective mailbox and anyone -interested in that mailbox reads the messages there. If anyone would -like to reply to a message, they do so and, this way, communication -flows among the interested crowd. If anyone would like to leave the -group, nothing is needed---the person just doesn't go back to read any -more messages. Unlike mailing lists, there is no need to formally -commit to reading one of these collective mailboxes and no need to -formally notify anyone or any system that you're not interested in -that group any longer. These collective mailboxes are called ``news -groups'' and are often written as ``newsgroups''. And the messages -posted to these newsgroups are called ``articles''. +UNIX V7, which was UUCP-ready, an acronym that stands for ``UNIX to +UNIX copy''. UUCP is both a protocol and a set of programs for +copying files between UNIX systems. People began exchanging messages +by copying files between machines. The idea of using UUCP for +exchanging messages eventually evolved into a protocol called +NNTP---Network News Transfer Protocol---, which is the protocol used +by \lp. (The protocol used to be called Netnews Transfer Protocol.) +Since e-mail was already daily practice of members of the Internet +back then, many things from e-mail were taken by the NNTP designers. +So, an NNTP message looks a lot like an e-mail message and the +two---NNTP and SMTP (the protocol used by e-mail)---can often mingle +seamlessly. The impression we get from using NNTP is that we're +sending e-mail to a certain group of people. It's as though the +message goes into a collective mailbox and anyone interested in that +mailbox reads the messages there. If anyone would like to reply to a +message, they do so and, this way, communication flows among the +interested crowd. If anyone would like to leave the group, nothing is +needed---the person just doesn't go back to read any more messages. +Unlike mailing lists, there is no need to formally commit to reading +one of these collective mailboxes and no need to formally notify +anyone or any system that you're not interested in that group any +longer. These collective mailboxes are called ``news groups'' and are +often written as ``newsgroups''. And the messages posted to these +newsgroups are called ``articles''. Just like e-mail and the web, network news is an open protocol. Anyone could write a program capable of speaking NNTP. There are many @@ -140,7 +144,7 @@ network news via NNTP. \section*{Principles for a discussion group}\label{principles} \pdfbookmark[1]{Principles for a discussion group}{principles} We believe a discussion group should be small and grow slowly. By -``slowly'', we mean that each member comes in through an invitation. +``slowly'' we mean that each member comes in through an invitation. This way, the group being closed by definition, we keep spam out and give members a certain sense of privilege. A discussion group should be formed by interested people. If a participant doesn't log-in for a @@ -148,11 +152,11 @@ certain period of time, \lp\ locks the participant's account---see Section \ref{sec:inactive-users}. The account can be reactivated, but it will take asking another participant (with an active account) to do so. In other words, there's an encouragement for an uninterested -member not to come back to the \lp. The idea is to keep a certain +member not to come back to the loop. The idea is to keep a certain cohesion in the discussion groups. When an account is locked or unlocked, an article is posted to the group {\tt local.control.news}, so everyone knows who is leaving and arriving. This way, participants -get to have an idea of who is reading them. +get to have an idea of who is reading, who is watching them. Each invitation comes with a certain responsibility: it's possible to see who invited who. If {\tt BOB} misbehaves, everyone gets to see @@ -403,7 +407,7 @@ there remains a \verb|\n| or \verb|\r\n| in the [[*standard-input*]], which we need to wipe out, or [[nntp-read-line]] will consume an empty line, which is what causes that 400 response. -<>= +<>= (defun repl (r) (in-package :loop) (loop @@ -441,12 +445,11 @@ How do we represent a client? A client is typically reading a group and an article; it's has authenticated itself or not yet. So we need a global structure to annonate the client's state. -<>= +<>= (defstruct client group (article 1) (username "ANONYMOUS") (auth? 'no)) (defparameter *client* (make-client)) @ %def client *client* - \section{Representation of a command} What does a client typically tell \lp? A client typically sends @@ -457,12 +460,12 @@ commands, which is essentially what the user sees when ask for \verb|HELP|. (Be aware that some clients use the output of \verb|HELP|. For example, Gnus v5.13.) -<>= +<>= (defstruct command fn verb description) (defparameter *commands-assoc* nil) @ -<>= +<
>= (defun table-of-commands () `(("GROUP" ,#'cmd-group "sets the current group") ("NEXT" ,#'cmd-next "increments the article pointer") @@ -529,12 +532,12 @@ integer as the code to a response, which is what we call the \verb|code| in the response. Long responses end with a period and we mark such responses with [[multi-line]]. -<>= +<>= (defstruct request verb args said) (defstruct response code data request multi-line) @ -<>= +<>= (defun empty-response () (make-response :code 400 :data "I beg your pardon?")) (defun prepend-response-with (message r) (make-response @@ -546,7 +549,7 @@ mark such responses with [[multi-line]]. Here's how to send a [[response]] to a client. -<>= +<>= (defun append-crlf-if-needed (seq) (cond ((stringp seq) @@ -585,7 +588,7 @@ It is not fine, however, when it's running in production. But, in production, {\tt (interactive-stream-p s)} will always be false. How else should we handle this? -<>= +<>= (defun my-write (ls-of-bytes s) (if (interactive-stream-p s) (write-sequence (mapcar #'code-char ls-of-bytes) s) @@ -606,7 +609,7 @@ says {\tt QUIT}, then we should identify it and terminate \lp's execution. That's even [[send-response!]] returns the [[request]] itself---so we can cascade actions based on a user's request. -<
>= +<
>= (defun main-loop () (loop (let* ((bs (nntp-read-line)) @@ -669,7 +672,7 @@ 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))) @@ -686,11 +689,16 @@ letters are equivalent in request verbs. We're using the clingon library as per Vincent Dardel suggestion in ``The Common Lisp Cookbook''. We begin with writing a description of -the program and options it understands. XXX: notice I don't know how -to support a two-argument option, so I hacked a solution away. What -we need to is to implement a new option. The library is extensible. +the program and options it understands. Notice I don't know how to +support a two-argument option, so I hacked a solution away. What we +need to is to implement a new option. The library is extensible. +However, I could be misremembering it here, but I recall having +decided to give up on the clingon library because it does too much. I +think it even handles {\tt SIGINT} on our backs. Nevertheless, do +notice that the library is doing a pretty good for a start, so unless +we understand exactly what it was that we didn't like, we'll keep it. -<>= +<>= (defun cli/options () (list (clingon:make-option @@ -731,7 +739,7 @@ We implement first the procedures that handle options that represent an entire program. For example, saying [[--list-accounts]] is like running a program [[./list-accounts]]. -<>= +<>= (defun cli/list-accounts () (println (str:join (crlf-string) (list-users)))) @@ -767,7 +775,7 @@ that because of the design of the [[clingon]] library, command-line parsing becomes the main procedure of \lp. In other words, \lp's service starts with [[server-start]]. -<>= +<>= (defun cli/main-with-handlers (cmd) (handler-case (cli/main cmd) @@ -826,7 +834,7 @@ response to whoever needs to catch it. For example, [[response-quit?]] is used by [[main-loop]] to identify when the user has issued {\tt QUIT}, in which case we terminate [[main-loop]]. -<>= +<>= (defun dispatch (r) (let* ((verb (request-verb r))) (if (null verb) @@ -857,11 +865,11 @@ I should've called the member [[headers]] as [[head]] and not suggest a list of parsed headers. We're going to rename this in due time. %% TODO -<>= +<>= (defstruct article headers body) @ -<>= +<>= (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)))) @@ -894,7 +902,7 @@ time. %% TODO We now write some procedures that we use when we're build the {\em overview} of the command \verb|XOVER|. -<>= +<>= (defun get-header-from-article (h a) (get-header h (parse-headers (article-headers (parse-article a))))) @@ -923,7 +931,7 @@ We just read the article bytes and handle them to the client. It's the article viewer's---the NNTP client's, that is---responsibility of interpreting such bytes. That's why we call [[read-sequence]] here. -<>= +<>= (defun fetch-article (g i) (in-groups (read-file-raw (format nil "~a/~a" g i)))) @@ -949,7 +957,7 @@ article. Since ``\verb|.\r\n|'' is part of the NNTP protocol, we must handle this gracefully---but notice we have not done anything about that so far. So we are essentially writing a bug right here. -<>= +<>= (defun encode-body (a) a) @ %def encode-body @@ -959,7 +967,7 @@ merge with [[extract-mid]]. I think I also wrote more redundancies---perhaps in the implementatio nof [[xover]]---for not using [[lookup]]. I need to seek out all such places and organize. %% TODO -<>= +<>= (defun extract-mid (a) (lookup "message-id" (parse-headers (article-headers (parse-article a))))) (defun lookup (key table) @@ -982,7 +990,7 @@ procedure at the REPL, but that's not so with [[labels]]. I guess the use of [[labels]] is when the procedure is so trivial that we have no reason to think we're doing to debug it.} -<>= +<>= (defun cmd-help (r) (let ((lines (menu *commands-assoc*))) (prepend-response-with @@ -1017,7 +1025,7 @@ procedure [[pass?]] that's defined in the implementation of {\tt Syntax error. Say ``authinfo USER /your-name/'' then ``authinfo PASS /your-pass/''. @ -<>= +<>= (defun cmd-authinfo (r) (let* ((args (mapcar #'str:upcase (request-args r)))) (cond @@ -1072,11 +1080,10 @@ Same as in @<
>. We'll let users create whatever complicated user names they want. If they can type it up, it's their problem. -<>= +<>= (defun user-name-conforms? (u) (conforms-to? u "<>")) -<>= (defun cmd-create-account (r) (with-auth (with-n-args 1 r @@ -1093,12 +1100,12 @@ it's their problem. username pass-or-error))))))))) @ -<>= +<>= (defstruct account username seen last-post friends pass pass-locked pass-locked-why creation) (defparameter *accounts* nil) @ %def *accounts* -<>= +<>= (defun read-accounts! () (let ((*package* (find-package '#:loop))) (with-open-file @@ -1143,7 +1150,7 @@ locking or we do something smarter without a real file locking mechanism. It's not clear to me what is possible here, but this is definitely a problem that we need to solve. -<>= +<>= (defun write-accounts! () (let ((name (loop @@ -1174,7 +1181,7 @@ Inactive accounts are removed or locked---see Section \ref{sec:inactive-users}. When an account is locked, any member can unlock it. -<>= +<>= (defun cmd-unlock-account (r) (with-auth (with-n-args 1 r @@ -1211,7 +1218,7 @@ implement a more convenient command for authenticationwhen we interact with \lp\ through a command-line interface. Instead of having to say two commands, we can just say {\tt login user password}. -<>= +<>= (defun cmd-login (r) (let* ((args (mapcar #'str:upcase (request-args r)))) (cond @@ -1238,7 +1245,7 @@ A change of password is made with {\tt PASSWD current new}. Observe that we are duplicating code from other command procedures. I think there is a macro emerging here called [[with-upcase-args]]. %% TODO -<>= +<>= (defun cmd-passwd (r) (with-auth (let* ((args (mapcar #'str:upcase (request-args r)))) @@ -1283,7 +1290,7 @@ there is a macro emerging here called [[with-upcase-args]]. %% TODO The tree of users and their friends is public. Anyone can know who invited who. -<>= +<>= (defun cmd-list-users (r) (with-auth (prepend-response-with @@ -1337,7 +1344,7 @@ think we should already be optimizing this by merely caching the information in a file that is read at start-up. I think we should even cache the overview of the group.) %% TODO -<>= +<>= (defstruct group name high low) (defun cmd-list (r) @@ -1379,7 +1386,7 @@ even cache the overview of the group.) %% TODO (defun article-ready? (path) (not (temporary-article? path))) -<> +<> (defun get-articles (g &optional from to) (in-groups ;; We might want to optimize this some day. That's a @@ -1417,7 +1424,7 @@ In [[basename]], what we want to do is---if the path ends with a slash, we invoke [[pathname]]. Otherwise, we invoke {\tt file-namestring}. -<>= +<>= (defun basename (path) (let ((s (str:collapse-whitespaces path))) (if (char= #\/ (last-char s)) @@ -1438,7 +1445,7 @@ To list directories and files, I have been using procedures below using the chunk [[#-cffi]] to get \Lp\ working on these systems. -<>= +<>= (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) @@ -1484,7 +1491,7 @@ To list directories and files, I have been using We just need to verify if the group exists and modify [[*client*]]. -<>= +<>= (defun cmd-group (r) (with-auth (with-n-args 1 r @@ -1523,7 +1530,7 @@ specifies the article number. In case (3), the NNTP client specifies the exact {\tt message-id}, which forces us to query the index---see Section~\ref{sec:index} for the implementation of the index. -<>= +<>= (defun typical-cmd-head-body-article (r fn-name) (with-auth (with-group-set @@ -1565,21 +1572,16 @@ must provide the size when producing the \verb|OVERVIEW|. If a problem such as [[sb-posix:syscall-error]] appears, we just inform the client and terminate the request---nothing else to do. -XXX: instead of only catching [[sb-posix:syscall-error]], we should -catch anything else, reporting the error. Otherwise, we will blow up -in case of some unexpected error, which might not be a bad idea---as -long as we can log these errors and get a report later on of what's -going on so we can improve the code. I still don't really know what -to do here. Let's leave it as it is. The original idea is to put a -[[t]]-case in the [[handler-case]] below and just log the error -instead of crashing completely. We can simulate the catching of an -unexpected condition by signaling it from fetch-article as a test. -This type of situation should have a testing routine as well. So, -yeah, first give yourself another read of the [[lisp-unit]] -documentation, then how to handle conditions properly and then come -back to this to-do item. +Our error checking strategy below is the following. If the user +requests an article we don't have, we figure it out with +[[fetch-article]]. If a system error come up such as a failed system +call, we report it to the user and log it---there's probably nothing +else we can do. The same is the case for all other errors. What I +want to do is to log it. What's important is that we seem to have +enough code to treat any future case we might want to add and we're +not ignoring any errors at all. -<>= +<>= (defun typical-cmd-response (code r g i get-data) (handler-case (let ((a (fetch-article g i))) @@ -1593,14 +1595,21 @@ back to this to-do item. (make-response :multi-line 'yes :code code :request r :data (funcall get-data a)))))) (sb-posix:syscall-error (c) - (make-response - :code 400 :request r - :data (format nil "article ~a/~a: ~a" g i c))))) + (let ((msg (format nil "article ~a/~a: ~a" g i c))) + (stderr msg) + (make-response + :code 400 :request r :data msg))) + (error (c) + (let ((msg (format nil "unexpected condition when reading article ~a/~a: ~a" g i c))) + (stderr msg) + (make-response + :code 400 :request r + :data msg))))) @ %def typical-cmd-response The command \verb|NEXT| has a slight different semantics. -<>= +<>= (defun cmd-next (r) (with-auth (let ((g (client-group *client*)) @@ -1631,7 +1640,7 @@ work. Notice that when the argument [[to]] from [[xover]] is [[NIL]], then the user is asking for articles indexed from the integer [[fr]] to the last one. -<>= +<>= (defun cmd-xover (r) (with-auth (with-group-set @@ -1685,7 +1694,7 @@ to the last one. So, we're always in reader mode, so we just ignore this command. -<>= +<>= (defun cmd-mode (r) ;; Whatever. (make-response :code 200 :request r :data "Sure thing.")) @ %def @@ -1695,7 +1704,7 @@ So, we're always in reader mode, so we just ignore this command. It's always useful to know the time and date at a computer. We should surely format it a bit better than what {\tt now} does. -<>= +<>= (defun cmd-date (r) (make-response :code 201 :request r @@ -1708,7 +1717,7 @@ surely format it a bit better than what {\tt now} does. The use of {\tt QUIT} has a conection to [[main-loop]]: when the user says {\tt QUIT}, [[main-loop]] must terminate. -<>= +<>= (defun cmd-quit (r) (make-response :code 205 :data "Good-bye." :request r)) @ %def @@ -1720,7 +1729,7 @@ shows to the client the internal state of how the server sees it. I've used only for debugging and it's not really useful any longer. I'm going to remove this very soon. -<>= +<>= (defun cmd-dd (r) (make-response :code 200 :data (format nil "state: ~a" *client*) :request r)) @ %def @@ -1735,8 +1744,8 @@ must have \verb|message-id|, \verb|subject|, \verb|from|, \verb|newsgroups|. If the client doesn't provide us with a \verb|message-id|, then \lp\ adds one. (Similarly for \verb|date|.) -<>= -<> +<>= +<> (defun suggest-message-id (&optional (n 20)) (format nil "<~a@loop>" (random-string n))) @@ -1753,7 +1762,7 @@ must have \verb|message-id|, \verb|subject|, \verb|from|, Sometimes we parse an article and sometimes we want to undo that parsing. Am I doing something wrong? I wonder. -<>= +<>= (defun unparse-article (parsed) (data (let ((ls)) @@ -1770,7 +1779,7 @@ If an article being posted has no \verb|message-id| or \verb|date|, procedures that would generate such headers if they're missing. Right now, however, we have only these two to worry about. -<>= +<>= (defun ensure-header (h fn bs) (let* ((headers (parse-headers (article-headers (parse-article bs))))) (if (lookup h headers) @@ -1820,7 +1829,7 @@ groups that mess up the local organization, then people should discuss the matter and find a solution. Let's let people mess it up instead of trying to stop them. -<>= +<>= (defun cmd-post (r) (with-auth (send-response! @@ -1854,7 +1863,7 @@ not conform for any reason). If we find any such group, then we refuse posting and return a 400 code with a message describing which group names failed. Otherwise we save the article. -<>= +<>= (defun post (bs) (let ((ngs (newsgroups-header->list (get-header "newsgroups" (parse-headers @@ -1891,7 +1900,7 @@ and saves the article more easily. That's a better idea. I think username to which to update the last-seen date should be included in the data structure. -<>= +<>= (defun update-last-post-date! (username) (let ((u (get-account username))) (setf (account-last-post u) (get-universal-time)))) @@ -1909,7 +1918,7 @@ target might be okay, but that's not allowed on Windows systems. Even though we have no interest in running \Lp\ on Windows, closing before renaming it sounds more like the Right Thing to do. -<>= +<>= (defun rename-no-extension (old new) (rename-file old (make-pathname :name new :type :unspecific))) @@ -1940,7 +1949,7 @@ The procedure [[save-article-insist]] insists on calling allocated. Notice that the argument [[name]] is an integer, so [[name]] is incremented at each iteration. -<>= +<>= (defun save-article-insist (g name a message-id) (loop for name from name do (in-dir (format nil "groups/~a/" g) @@ -1962,7 +1971,7 @@ is. This is important to speed up posting. For instance, if we allow attachments (which we don't), the performance penalty is clearly noticeable. %%TODO -<>= +<>= (defun nntp-read-article (&optional acc) ;; Returns List-of Byte. (let* ((ls (ucs-2->ascii (nntp-read-line)))) @@ -1981,7 +1990,7 @@ because sometimes the list [[acc]] comes out empty, but an empty line never comes from the NNTP protocol because there's is always a {\tt CR} before {\tt LF}. -<>= +<>= (defun nntp-read-line (&optional (s *standard-input*) acc) ;; Returns List-of Byte. (let ((x (read-byte s))) @@ -2033,7 +2042,7 @@ does. I need to review this and then add the explanation for myself. If I don't remember how this works, other beginners won't know it either. %% TODO -<>= +<>= (defun conforms? (bs) (catch 'article-syntax-error ;; parse-headers might throw (let ((headers (parse-headers (article-headers (parse-article bs))))) @@ -2090,7 +2099,7 @@ created. People then have a chance to subscribe to the new group. We assume that when someone creates a group, it's either no problem at all or it has been discussed with the community beforehand. -<>= +<>= (defun cmd-create-group (r) (with-n-args 1 r (let ((g (string-downcase (car (request-args r))))) @@ -2123,7 +2132,7 @@ all or it has been discussed with the community beforehand. \lp\ is totally {\em hackable}. Users can say {\tt repl} to have complete control over their \lxxp\ process. -<>= +<>= (defun cmd-repl (r) (if *enable-nntp-repl* (with-auth @@ -2141,7 +2150,7 @@ to \lp\ because this way users are advertised about the commands that exist---they could be having fun, but their sysadmin doesn't think they're skilled enough. -<>= +<>= (defparameter *enable-nntp-repl* t) @ @@ -2151,7 +2160,7 @@ If you're interested in being notified about what's going on in the \lp, then subscribe to {\tt local.control.news}. Group creation, invitations {\em et cetera} are published there. -<>= +<>= (defun notify-group-created (g) (post-notification :subject (fmt "new group ~a by ~a" g (client-username *client*)) @@ -2196,7 +2205,7 @@ When we find this line termination, we have its position in the consumed list. With the position, we collect the line and we iterate searching for the next line. -<>= +<>= (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))) @@ -2253,11 +2262,11 @@ convenient for us: we don't need to specify with which database we're working. Since we work with only one, we pretty much never need to specify anything. -<>= +<>= (defparameter *default-database* nil) @ %def *default-database* -<>= +<>= (defun connect-index! (filename) (setq *default-database* (clsql:connect (list filename) :database-type :sqlite3))) @@ -2333,7 +2342,7 @@ Sure---in the future, we will not duplicate articles in storage; we will make symbolic links. We don't do that right now because Windows doesn't really support symbolic links. -<>= +<>= (defun insert-index (m g i) (handler-case (clsql:insert-records @@ -2382,7 +2391,7 @@ group, we get the name of the file relative to the article---that's the numeric ID of the article---and its {\tt message-id}. That's all we need to index it. -<>= +<>= (defun index-from-fs! () (loop for path in (in-groups (directory "**/*")) do (let* ((g (str:trim (first (last (pathname-directory path))))) @@ -2400,7 +2409,7 @@ we need to index it. Here's a program to build the index from a UNIX shell. <>= -<> +<> (ql:quickload :loop :silent t) (in-package #:loop) (connect-index! "message-id.db") @@ -2428,7 +2437,7 @@ Index built. We now implement some of the \hyperref[principles]{principles} exposed earlier on page~\pageref{principles}. The program -@<> would be run by {\tt cron} every +@<> would be run by {\tt cron} every day (at midnight, say). It checks all accounts that are inactive and either locks them (to be deleted later) or deletes them {\em for good}. If you want to keep accounts forever, just don't run the @@ -2437,7 +2446,7 @@ that are locked (by the same period of time), but we have not yet done that. <>= -<> +<> (ql:quickload :loop :silent t) (in-package #:loop) (read-accounts!) @@ -2448,7 +2457,7 @@ that. The entire program is really [[remove-inactive-users!]]. -<>= +<>= (defun remove-inactive-users! () (loop for u in *accounts* do (let ((username (account-username u))) @@ -2484,7 +2493,7 @@ take effect---for example, when deleting the first element of a list. lists are implemented in C, say, then you're likely well aware of how it works.) -<>= +<>= (defun remove-account! (username) (loop for u in *accounts* do (setf (account-friends u) @@ -2508,7 +2517,7 @@ New system administrators of \Lp\ will never need to run this. (We do not remove this set of source code chunks because they serve as an example of how to a migration like that.) -<>= +<>= (defun loop-epoch () (encode-timestamp 0 0 0 0 1 1 2024)) @@ -2524,7 +2533,7 @@ example of how to a migration like that.) Here's a program to run the migration in a UNIX shell. <>= -<> +<> (ql:quickload :loop :silent t) (in-package #:loop) (migrate-add-creation-and-post-date!) @@ -2533,12 +2542,12 @@ Here's a program to run the migration in a UNIX shell. Now we write the procedures that discover what accounts are inactive. -<>= +<>= (defparameter *months-inactive-allowed* 3) (defparameter *months-never-logged-in* 1) @ -<>= +<>= (defun user-inactive? (username) (or (inactive-from-never-logged-in? username) (inactive-from-last-seen? username))) @@ -2598,7 +2607,7 @@ example, when we need to access the group database, we use [[in-groups]]. When a certain command demands authentication, we use [[with-auth]]. -<>= +<>= (defmacro in-dir (dir &rest body) `(let ((*default-pathname-defaults* (truename ,dir))) (uiop:with-current-directory (,dir) @@ -2612,7 +2621,7 @@ the current working directory. We did this out of the fact that we used to invoke [[renameat2]] through the [[cffi]], but we don't use it any more. -<>= +<>= (defmacro in-groups (&rest body) `(in-dir "groups/" ,@body)) (defun in-group-lambda (g fn) (in-dir g (funcall fn))) @@ -2664,7 +2673,7 @@ of UCS-2. Despite the name UCS-2, notice it is UTF-16. The name UCS stands for ``Universal Character Set'' and I speculate the number 2 means 2 bytes. So our conversion is just removing the first byte. -<>= +<>= (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))) @@ -2773,7 +2782,7 @@ directory in which \lp's tests will find the groups directory in place. Making that happen is as simple as changing [[*default-pathname-defaults*]]. -<>= +<>= (setq lisp-unit:*print-failures* t) (define-test dispatching (assert-true (equalp (empty-response) (dispatch (make-request))))) @@ -2823,7 +2832,7 @@ taking place---here in the REPL at least. Just say {\tt make loop} to your shell. <>= -<> +<> (ql:quickload :loop) (sb-ext:save-lisp-and-die #P"loop" :toplevel #'loop:main @@ -2831,7 +2840,7 @@ Just say {\tt make loop} to your shell. :save-runtime-options t) @ -<>= +<>= #-quicklisp (let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))) @@ -2895,7 +2904,7 @@ something to think about. ;;; -*- mode: LISP; syntax: COMMON-LISP; package: LOOP; -*- (eval-when (:compile-toplevel :load-toplevel :execute) (ql:quickload - '(<>) + '(<>) :silent t)) (clsql:file-enable-sql-reader-syntax) @@ -2910,59 +2919,59 @@ something to think about. (in-package #:loop) -<> -<
> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<> -<
> -<> +<> +<
> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<> +<
> +<> @ %def -<>= +<>= (defparameter *debug* nil) -<> -<> -<> -<> -<> -<> -<> -<> +<> +<> +<> +<> +<> +<> +<> +<> @ On which packages do we depend? -<>= +<>= :lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon :filesystem-utils :ironclad/digest/sha256 @ @@ -2974,7 +2983,7 @@ The \lp\ system definition: (asdf:defsystem :<> :version "<>" :description "<>" - :depends-on (<>) + :depends-on (<>) :components ((:file "loop"))) @ @@ -3005,7 +3014,7 @@ delete the {\em first} blank line and not the second---that's what the {\tt D} command does. This strategy is explained by Dale Dougherty and Arnold Robbins in ``sed \& awk'' second edition, pages 112--114. -<>= +<>= #!/bin/sh usage() { @@ -3040,7 +3049,7 @@ the body of the chunk @<>. The {\tt sed} program is straightforward: locate the chunk definition, move down a line, change that line and that's all. -<>= +<>= #!/bin/sh usage() {