Implements a REPL for Lisp hackers.
This commit is contained in:
parent
e8b57771f5
commit
83e0aeffa1
3 changed files with 163 additions and 130 deletions
5
Makefile
5
Makefile
|
@ -1,8 +1,9 @@
|
||||||
default: loop
|
default: loop shell
|
||||||
|
|
||||||
loop: loop.asd loop.lisp scripts/build-exe.lisp
|
loop: loop.asd loop.lisp scripts/build-exe.lisp
|
||||||
sbcl --script scripts/build-exe.lisp
|
sbcl --script scripts/build-exe.lisp
|
||||||
|
|
||||||
install: loop
|
install: loop
|
||||||
mkdir -p `head -1 conf-home` && \
|
mkdir -p `head -1 conf-home` && \
|
||||||
cp -R loop accounts.lisp groups scripts `head -1 conf-home`
|
cp -R loop loop-shell accounts.lisp groups scripts \
|
||||||
|
`head -1 conf-home`
|
||||||
|
|
64
loop.lisp
64
loop.lisp
|
@ -51,7 +51,8 @@
|
||||||
("DD" ,#'cmd-dd "[d]isplays [d]ata: your state of affairs")
|
("DD" ,#'cmd-dd "[d]isplays [d]ata: your state of affairs")
|
||||||
("QUIT" ,#'cmd-quit "politely says good-bye")
|
("QUIT" ,#'cmd-quit "politely says good-bye")
|
||||||
("DATE" ,#'cmd-date "displays the current date at this server")
|
("DATE" ,#'cmd-date "displays the current date at this server")
|
||||||
("UNLOCK-ACCOUNT" ,#'cmd-unlock-account "unlocks an account")))
|
("UNLOCK-ACCOUNT" ,#'cmd-unlock-account "unlocks an account")
|
||||||
|
("REPL" ,#'cmd-repl "lets you hack away")))
|
||||||
|
|
||||||
(defun set-up-tables! ()
|
(defun set-up-tables! ()
|
||||||
(labels ((build-commands-assoc (ls)
|
(labels ((build-commands-assoc (ls)
|
||||||
|
@ -122,6 +123,10 @@
|
||||||
(make-response :code 400 :data "You must authenticate first.")
|
(make-response :code 400 :data "You must authenticate first.")
|
||||||
(progn ,@body)))
|
(progn ,@body)))
|
||||||
|
|
||||||
|
(defun print/finish (&rest args)
|
||||||
|
(apply #'format (cons t args))
|
||||||
|
(finish-output))
|
||||||
|
|
||||||
(defun plural (v suffix)
|
(defun plural (v suffix)
|
||||||
(if (> v 1) suffix ""))
|
(if (> v 1) suffix ""))
|
||||||
|
|
||||||
|
@ -134,7 +139,8 @@
|
||||||
|
|
||||||
(defun stderr (&rest args)
|
(defun stderr (&rest args)
|
||||||
(when *debug*
|
(when *debug*
|
||||||
(apply #'out (cons *error-output* args))))
|
(apply #'out (cons *error-output* args))
|
||||||
|
(finish-output *error-output*)))
|
||||||
|
|
||||||
(defun stdout (&rest args)
|
(defun stdout (&rest args)
|
||||||
(apply #'out (list* *standard-output* args)))
|
(apply #'out (list* *standard-output* args)))
|
||||||
|
@ -180,6 +186,17 @@
|
||||||
|
|
||||||
(defmacro mac (&rest body)
|
(defmacro mac (&rest body)
|
||||||
`(macroexpand-1 ,@body))
|
`(macroexpand-1 ,@body))
|
||||||
|
(defun repl (r)
|
||||||
|
(in-package :loop)
|
||||||
|
(loop
|
||||||
|
(print/finish "LOOP> ")
|
||||||
|
(let ((expr (read)))
|
||||||
|
(if (eq 'quit expr)
|
||||||
|
(return
|
||||||
|
(make-response
|
||||||
|
:code 200 :request r
|
||||||
|
:data "Okay, no more REPL hacking."))
|
||||||
|
(println "~a" (eval expr))))))
|
||||||
(defun empty-response () (make-response :code 400 :data "I beg your pardon?"))
|
(defun empty-response () (make-response :code 400 :data "I beg your pardon?"))
|
||||||
(defun prepend-response-with (message r)
|
(defun prepend-response-with (message r)
|
||||||
(make-response
|
(make-response
|
||||||
|
@ -1120,7 +1137,7 @@
|
||||||
(let ((u (get-account username)))
|
(let ((u (get-account username)))
|
||||||
(when (not u)
|
(when (not u)
|
||||||
(error "I could not find account ~a." username))
|
(error "I could not find account ~a." username))
|
||||||
(setf (account-pass u) (string->sha256 newpass))
|
(setf (account-pass u) (string->sha256 (str:upcase newpass)))
|
||||||
(write-accounts!)))
|
(write-accounts!)))
|
||||||
|
|
||||||
(defun cmd-list-users (r)
|
(defun cmd-list-users (r)
|
||||||
|
@ -1166,6 +1183,9 @@
|
||||||
(if s (universal-to-human s))))))
|
(if s (universal-to-human s))))))
|
||||||
(defun cmd-dd (r)
|
(defun cmd-dd (r)
|
||||||
(make-response :code 200 :data (format nil "state: ~a" *client*) :request r))
|
(make-response :code 200 :data (format nil "state: ~a" *client*) :request r))
|
||||||
|
(defun cmd-repl (r)
|
||||||
|
(with-auth
|
||||||
|
(repl r)))
|
||||||
|
|
||||||
(defun notify-group-created (g)
|
(defun notify-group-created (g)
|
||||||
(post-notification
|
(post-notification
|
||||||
|
@ -1220,19 +1240,13 @@
|
||||||
:key :list-accounts)
|
:key :list-accounts)
|
||||||
(clingon:make-option
|
(clingon:make-option
|
||||||
:flag
|
:flag
|
||||||
:description "runs NNTP server reading from stdout"
|
:description "runs a REPL"
|
||||||
:short-name #\s
|
|
||||||
:long-name "server"
|
|
||||||
:key :server)
|
|
||||||
(clingon:make-option
|
|
||||||
:flag
|
|
||||||
:description "run a REPL on port 4006"
|
|
||||||
:short-name #\r
|
:short-name #\r
|
||||||
:long-name "repl"
|
:long-name "repl"
|
||||||
:key :repl)
|
:key :repl)
|
||||||
(clingon:make-option
|
(clingon:make-option
|
||||||
:flag
|
:flag
|
||||||
:description "turn on debug logging on stderr"
|
:description "logging (on stderr)"
|
||||||
:long-name "logging"
|
:long-name "logging"
|
||||||
:key :logging)))
|
:key :logging)))
|
||||||
(defun cli/list-accounts ()
|
(defun cli/list-accounts ()
|
||||||
|
@ -1270,29 +1284,27 @@
|
||||||
(create-index!)
|
(create-index!)
|
||||||
(let ((args (clingon:command-arguments cmd))
|
(let ((args (clingon:command-arguments cmd))
|
||||||
(repl (clingon:getopt cmd :repl))
|
(repl (clingon:getopt cmd :repl))
|
||||||
(server (clingon:getopt cmd :server))
|
|
||||||
(ca (clingon:getopt cmd :create-account))
|
(ca (clingon:getopt cmd :create-account))
|
||||||
(change-passwd-account (clingon:getopt cmd :change-passwd))
|
(pa (clingon:getopt cmd :change-passwd))
|
||||||
(list-accounts (clingon:getopt cmd :list-accounts))
|
(la (clingon:getopt cmd :list-accounts))
|
||||||
(logging (clingon:getopt cmd :logging)))
|
(logging (clingon:getopt cmd :logging)))
|
||||||
(setf *debug* logging)
|
(setf *debug* logging)
|
||||||
(when list-accounts
|
(when la
|
||||||
(cli/list-accounts))
|
(cli/list-accounts))
|
||||||
(when ca
|
(when ca
|
||||||
(cli/create-account ca args))
|
(cli/create-account ca args))
|
||||||
(when change-passwd-account
|
(when pa
|
||||||
(cli/change-passwd change-passwd-account args))
|
(cli/change-passwd pa args))
|
||||||
(when repl
|
(when repl
|
||||||
(stderr "Running a REPL on localhost:4006...~%"))
|
(repl))
|
||||||
(when server
|
(when (and (not la) (not ca) (not pa))
|
||||||
(server-start))))
|
(server-start))))
|
||||||
|
|
||||||
(defun cli/command ()
|
(defun cli/command ()
|
||||||
(clingon:make-command
|
(clingon:make-command
|
||||||
:name "loop"
|
:name "loop"
|
||||||
:description "An NNTP server for a circle of friends."
|
:description "An NNTP server for a circle of friends."
|
||||||
:version "0.1"
|
:version "0.1" ;; :authors '("Circling Skies <loop@antartida.xyz>")
|
||||||
:authors '("Circling Skies <loop@antartida.xyz>")
|
|
||||||
:license "GPL v3"
|
:license "GPL v3"
|
||||||
:options (cli/options)
|
:options (cli/options)
|
||||||
:handler #'cli/main))
|
:handler #'cli/main))
|
||||||
|
@ -1300,13 +1312,9 @@
|
||||||
(defun main-loop ()
|
(defun main-loop ()
|
||||||
(let* ((bs (nntp-read-line))
|
(let* ((bs (nntp-read-line))
|
||||||
(ln (bytes->string (ucs-2->ascii bs))))
|
(ln (bytes->string (ucs-2->ascii bs))))
|
||||||
(handler-case
|
(let ((r (send-response! (dispatch-line ln))))
|
||||||
(let ((r (send-response! (dispatch-line ln))))
|
(when (not (response-quit? r))
|
||||||
(when (not (response-quit? r))
|
(main-loop)))))
|
||||||
(main-loop)))
|
|
||||||
(SB-SYS:INTERACTIVE-INTERRUPT (c)
|
|
||||||
(declare (ignore c))
|
|
||||||
(stderr "^c~%")))))
|
|
||||||
|
|
||||||
(defun request-quit? (r) (and r (string= 'quit (request-verb r))))
|
(defun request-quit? (r) (and r (string= 'quit (request-verb r))))
|
||||||
(defun response-quit? (r) (and r (request-quit? (response-request r))))
|
(defun response-quit? (r) (and r (request-quit? (response-request r))))
|
||||||
|
|
224
loop.nw
224
loop.nw
|
@ -88,10 +88,10 @@ But \lp\ has nothing to do with e-mail. \Lp\ uses a communication
|
||||||
strategy---called a ``protocol''---that is even older than the web
|
strategy---called a ``protocol''---that is even older than the web
|
||||||
itself. The web started out around 1989--1990 and the protocol
|
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
|
\lp\ uses begins its history in 1979, the year in which AT\&T released
|
||||||
UNIX V7, which was UUCP-ready. The name UUCP stands for [U]NIX to
|
UNIX V7, which was UUCP-ready, an acronym that stands for for UNIX to
|
||||||
[U]NIX [c]o[p]y. It's both a protocol and a set of programs for
|
UNIX copy. It's both a protocol and a set of programs for copying
|
||||||
copying files between UNIX systems. People begun exchanging messages
|
files between UNIX systems. People begun exchanging messages by
|
||||||
by copying files between machines. The idea eventually evolved into a
|
copying files between machines. The idea eventually evolved into a
|
||||||
protocol called NNTP---Network News Transfer Protocol---, which is the
|
protocol called NNTP---Network News Transfer Protocol---, which is the
|
||||||
protocol used by \lp. (The protocol used to be called Netnews
|
protocol used by \lp. (The protocol used to be called Netnews
|
||||||
Transfer Protocol.) Since e-mail was already daily practice of
|
Transfer Protocol.) Since e-mail was already daily practice of
|
||||||
|
@ -136,7 +136,7 @@ network news via NNTP.
|
||||||
\label{fg:sylpheed}
|
\label{fg:sylpheed}
|
||||||
\end{figure}
|
\end{figure}
|
||||||
|
|
||||||
{\bf Principles for a discussion group}. We believe a discussion group
|
\noindent{\bf Principles for a discussion group}. We believe a discussion group
|
||||||
should be small and grow slowly. By ``slowly'', we mean that each
|
should be small and grow slowly. By ``slowly'', we mean that each
|
||||||
member comes in through an invitation. This way, the group being
|
member comes in through an invitation. This way, the group being
|
||||||
closed by definition, we keep spam out and give members a certain
|
closed by definition, we keep spam out and give members a certain
|
||||||
|
@ -185,7 +185,7 @@ just want to use the system, you probably should stop right here.
|
||||||
|
|
||||||
See \href{https://git.antartida.xyz/loop/srv/raw/branch/main/README}{[[README]]}.
|
See \href{https://git.antartida.xyz/loop/srv/raw/branch/main/README}{[[README]]}.
|
||||||
|
|
||||||
\section{The implementation strategy}\label{sec:design}
|
\section{Implementation strategy}\label{sec:design}
|
||||||
|
|
||||||
Anything a user sends to the \lp\ is wrapped in a [[request]] and
|
Anything a user sends to the \lp\ is wrapped in a [[request]] and
|
||||||
any command processing must produce a [[response]]:
|
any command processing must produce a [[response]]:
|
||||||
|
@ -313,33 +313,28 @@ quit
|
||||||
205 Good-bye.
|
205 Good-bye.
|
||||||
\end{verbatim}
|
\end{verbatim}
|
||||||
|
|
||||||
But keep in mind that \lp\ was not made to talk to users directly.
|
Despite \lp being made to talk to computer programs such as the ones
|
||||||
\Lp\ was made to talk to your NNTP client, programs such as the ones
|
illustrated in Figures~\ref{fg:gnus}--\ref{fg:sylpheed}, it's
|
||||||
illustrated by Figures \ref{fg:gnus}--\ref{fg:sylpheed}. That's why
|
|
||||||
we see these numbers in the responses given by \lp. These numbers are
|
|
||||||
there to help clients understand how the conversation is going. Each
|
|
||||||
specific such number is determined by the NNTP protocol. But, despite
|
|
||||||
the protocol being made for machines to talk to each other, it's
|
|
||||||
perfectly possible for a user to interact with \lp\ directly using a
|
perfectly possible for a user to interact with \lp\ directly using a
|
||||||
keyboard and a command-line tool such as {\tt nc} or {\tt telnet}. In
|
keyboard and a command-line tool such as {\tt nc} or {\tt telnet}. In
|
||||||
fact, \lp\ takes advantage of that to be hackable. \Lp\ was written
|
fact, \lp\ takes advantage of that to be {\em hackable}. Commands
|
||||||
so that it can talk to NNTP clients---such as Gnus, Sylpheed {\em et
|
such as [[CREATE-ACCOUNT]], [[CREATE-GROUP]], [[PASSWD]] are not part
|
||||||
cetera}---but also to users directly. Commands such as
|
of the NNTP protocol, so users need to know how to use {\tt nc} or
|
||||||
[[CREATE-ACCOUNT]], [[CREATE-GROUP]], [[PASSWD]] are not part of the
|
{\tt telnet} to take advantage of all of \lp's capabilities.
|
||||||
NNTP protocol, so users need to know how to use {\tt nc} or {\tt
|
|
||||||
telnet} to take advantage of all of \lp's capabilities.
|
|
||||||
|
|
||||||
\section{The NNTP protocol}
|
\section{NNTP protocol}
|
||||||
|
|
||||||
An Internet protocol is usually defined by a document whose tradition
|
An Internet protocol is usually defined by a document whose tradition
|
||||||
calls RFC---for ``[r]equest [f]or [c]omments''. The NNTP protocol is
|
calls RFC---for ``request for comments''---, an acronym suggested by
|
||||||
defined by RFCs 977, 2980, 3977, 4643 and 5536. RFC 977 was the first
|
Stephen D.~Crocker, who wrote RFC 1 back in 1969, when ARPANET
|
||||||
and replaced by 3977. Still, reading RFC 977 is interesting precisely
|
connected four computers. NNTP is defined by RFCs 977, 2980, 3977,
|
||||||
because it gives us a historical account of the protocol, making it
|
4643 and 5536. RFC 977 was the first and replaced by 3977. Still,
|
||||||
easier to understanding the evolution of the system. The objective of
|
reading RFC 977 is interesting precisely because it gives us a
|
||||||
RFC 2980 was to implement new ideas to the NNTP protocol---to extend
|
historical account of the protocol, making it easier to understand the
|
||||||
the protocol. RFC 3977 adopts some of these extensions. RFC 4643
|
evolution of the system. The objective of RFC 2980 was to implement
|
||||||
also extends RFC 2980---addressing concerns with authentication.
|
new ideas to the NNTP protocol---to extend the protocol. RFC 3977
|
||||||
|
adopts some of these extensions. RFC 4643 also extends RFC
|
||||||
|
2980---addressing concerns with authentication.
|
||||||
|
|
||||||
\section{It's a network server}
|
\section{It's a network server}
|
||||||
|
|
||||||
|
@ -370,7 +365,36 @@ way, they work together. And \lp\ handles only a text stream, which
|
||||||
is why it's so easy to connect a keyboard to it and interact with it
|
is why it's so easy to connect a keyboard to it and interact with it
|
||||||
through the command line as illustrated in Section~\ref{sec:design}.
|
through the command line as illustrated in Section~\ref{sec:design}.
|
||||||
|
|
||||||
\section{The description of the package}
|
\section{REPL for \lp}
|
||||||
|
|
||||||
|
There's a REPL to \lp's procedures---always useful.
|
||||||
|
|
||||||
|
\begin{verbatim}
|
||||||
|
%./loop --repl
|
||||||
|
LOOP> (+ 1 1)
|
||||||
|
2
|
||||||
|
LOOP> (list-groups)
|
||||||
|
(local.control.news local.test)
|
||||||
|
\end{verbatim}
|
||||||
|
|
||||||
|
We implement it by creating a [[repl]] procedure in \lp's package with
|
||||||
|
an option handled by [[cli/command]].
|
||||||
|
|
||||||
|
<<Loop's REPL>>=
|
||||||
|
(defun repl (r)
|
||||||
|
(in-package :loop)
|
||||||
|
(loop
|
||||||
|
(print/finish "LOOP> ")
|
||||||
|
(let ((expr (read)))
|
||||||
|
(if (eq 'quit expr)
|
||||||
|
(return
|
||||||
|
(make-response
|
||||||
|
:code 200 :request r
|
||||||
|
:data "Okay, no more REPL hacking."))
|
||||||
|
(println "~a" (eval expr))))))
|
||||||
|
@ %def repl
|
||||||
|
|
||||||
|
\section{Description of the package}
|
||||||
|
|
||||||
<<Description>>=
|
<<Description>>=
|
||||||
An NNTP server for a circle of friends.
|
An NNTP server for a circle of friends.
|
||||||
|
@ -382,7 +406,7 @@ An NNTP server for a circle of friends.
|
||||||
|
|
||||||
These chunks are used in [[loop.asd]].
|
These chunks are used in [[loop.asd]].
|
||||||
|
|
||||||
\section{The representation of a client}
|
\section{Representation of a client}
|
||||||
|
|
||||||
How do we represent a client? A client is typically reading a group
|
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
|
and an article; it's has authenticated itself or not yet. So we need
|
||||||
|
@ -394,7 +418,7 @@ a global structure to annonate the client's state.
|
||||||
@ %def client *client*
|
@ %def client *client*
|
||||||
|
|
||||||
|
|
||||||
\section{The representation of a command}
|
\section{Representation of a command}
|
||||||
|
|
||||||
What does a client typically tell \lp? A client typically sends
|
What does a client typically tell \lp? A client typically sends
|
||||||
commands. Commands typically need arguments. Each command is
|
commands. Commands typically need arguments. Each command is
|
||||||
|
@ -432,7 +456,8 @@ commands, which is essentially what the user sees when ask for
|
||||||
("DD" ,#'cmd-dd "[d]isplays [d]ata: your state of affairs")
|
("DD" ,#'cmd-dd "[d]isplays [d]ata: your state of affairs")
|
||||||
("QUIT" ,#'cmd-quit "politely says good-bye")
|
("QUIT" ,#'cmd-quit "politely says good-bye")
|
||||||
("DATE" ,#'cmd-date "displays the current date at this server")
|
("DATE" ,#'cmd-date "displays the current date at this server")
|
||||||
("UNLOCK-ACCOUNT" ,#'cmd-unlock-account "unlocks an account")))
|
("UNLOCK-ACCOUNT" ,#'cmd-unlock-account "unlocks an account")
|
||||||
|
("REPL" ,#'cmd-repl "lets you hack away")))
|
||||||
|
|
||||||
(defun set-up-tables! ()
|
(defun set-up-tables! ()
|
||||||
(labels ((build-commands-assoc (ls)
|
(labels ((build-commands-assoc (ls)
|
||||||
|
@ -461,7 +486,7 @@ commands, which is essentially what the user sees when ask for
|
||||||
(or (cdr cmd) (unrecognized-command)))))
|
(or (cdr cmd) (unrecognized-command)))))
|
||||||
@ %def *commands-assoc* set-up-tables! get-command
|
@ %def *commands-assoc* set-up-tables! get-command
|
||||||
|
|
||||||
\section{The representation of requests and responses}
|
\section{Representation of requests and responses}
|
||||||
|
|
||||||
Each command is given through a text line written by the user. Let's
|
Each command is given through a text line written by the user. Let's
|
||||||
call this text line the [[request]]. When \lp\ parses the request, it
|
call this text line the [[request]]. When \lp\ parses the request, it
|
||||||
|
@ -538,7 +563,7 @@ else should we handle this?
|
||||||
(write-sequence ls-of-bytes s)))
|
(write-sequence ls-of-bytes s)))
|
||||||
@ %def my-write
|
@ %def my-write
|
||||||
|
|
||||||
\section{The parsing of requests}
|
\section{Parsing of requests}
|
||||||
|
|
||||||
The commands themselves we call {\tt verbs} and everything else the
|
The commands themselves we call {\tt verbs} and everything else the
|
||||||
user types we call {\tt args}. Observe that upper and lower case
|
user types we call {\tt args}. Observe that upper and lower case
|
||||||
|
@ -557,7 +582,7 @@ letters are equivalent in request verbs.
|
||||||
:args args))))))
|
:args args))))))
|
||||||
@ %def parse-request
|
@ %def parse-request
|
||||||
|
|
||||||
\section{The main loop}
|
\section{Main loop}
|
||||||
|
|
||||||
Every command consumes a [[request]] and produces a [[response]]. If
|
Every command consumes a [[request]] and produces a [[response]]. If
|
||||||
any procedure always produces a [[response]], then delivering a
|
any procedure always produces a [[response]], then delivering a
|
||||||
|
@ -575,13 +600,9 @@ itself---so we can cascade actions based on a user's request.
|
||||||
(defun main-loop ()
|
(defun main-loop ()
|
||||||
(let* ((bs (nntp-read-line))
|
(let* ((bs (nntp-read-line))
|
||||||
(ln (bytes->string (ucs-2->ascii bs))))
|
(ln (bytes->string (ucs-2->ascii bs))))
|
||||||
(handler-case
|
(let ((r (send-response! (dispatch-line ln))))
|
||||||
(let ((r (send-response! (dispatch-line ln))))
|
(when (not (response-quit? r))
|
||||||
(when (not (response-quit? r))
|
(main-loop)))))
|
||||||
(main-loop)))
|
|
||||||
(SB-SYS:INTERACTIVE-INTERRUPT (c)
|
|
||||||
(declare (ignore c))
|
|
||||||
(stderr "^c~%")))))
|
|
||||||
|
|
||||||
(defun request-quit? (r) (and r (string= 'quit (request-verb r))))
|
(defun request-quit? (r) (and r (string= 'quit (request-verb r))))
|
||||||
(defun response-quit? (r) (and r (request-quit? (response-request r))))
|
(defun response-quit? (r) (and r (request-quit? (response-request r))))
|
||||||
|
@ -600,13 +621,12 @@ itself---so we can cascade actions based on a user's request.
|
||||||
(make-response :code 200 :data "Welcome! Say ``help'' for a menu.")))
|
(make-response :code 200 :data "Welcome! Say ``help'' for a menu.")))
|
||||||
@ %def main main-loop
|
@ %def main main-loop
|
||||||
|
|
||||||
\section{Command-line parsing}
|
\section{Parsing of command-line arguments}
|
||||||
|
|
||||||
We're using the clingon library as per Vincent Dardel suggestion in
|
We're using the clingon library as per Vincent Dardel suggestion in
|
||||||
``The Common Lisp Cookbook''. (Thanks, Vincent!) We begin with
|
``The Common Lisp Cookbook''. We begin with writing a description of
|
||||||
writing a description of the program and options it understands. XXX:
|
the program and options it understands. XXX: notice I don't know how
|
||||||
notice I don't know how to support a two-argument option, so I hacked
|
to support a two-argument option, so I hacked a solution away.
|
||||||
a solution away.
|
|
||||||
|
|
||||||
<<Command-line parsing>>=
|
<<Command-line parsing>>=
|
||||||
(defun cli/options ()
|
(defun cli/options ()
|
||||||
|
@ -629,19 +649,13 @@ a solution away.
|
||||||
:key :list-accounts)
|
:key :list-accounts)
|
||||||
(clingon:make-option
|
(clingon:make-option
|
||||||
:flag
|
:flag
|
||||||
:description "runs NNTP server reading from stdout"
|
:description "runs a REPL"
|
||||||
:short-name #\s
|
|
||||||
:long-name "server"
|
|
||||||
:key :server)
|
|
||||||
(clingon:make-option
|
|
||||||
:flag
|
|
||||||
:description "run a REPL on port 4006"
|
|
||||||
:short-name #\r
|
:short-name #\r
|
||||||
:long-name "repl"
|
:long-name "repl"
|
||||||
:key :repl)
|
:key :repl)
|
||||||
(clingon:make-option
|
(clingon:make-option
|
||||||
:flag
|
:flag
|
||||||
:description "turn on debug logging on stderr"
|
:description "logging (on stderr)"
|
||||||
:long-name "logging"
|
:long-name "logging"
|
||||||
:key :logging)))
|
:key :logging)))
|
||||||
@
|
@
|
||||||
|
@ -694,35 +708,33 @@ Now let's write the main procedure in command-line parsing.
|
||||||
(create-index!)
|
(create-index!)
|
||||||
(let ((args (clingon:command-arguments cmd))
|
(let ((args (clingon:command-arguments cmd))
|
||||||
(repl (clingon:getopt cmd :repl))
|
(repl (clingon:getopt cmd :repl))
|
||||||
(server (clingon:getopt cmd :server))
|
|
||||||
(ca (clingon:getopt cmd :create-account))
|
(ca (clingon:getopt cmd :create-account))
|
||||||
(change-passwd-account (clingon:getopt cmd :change-passwd))
|
(pa (clingon:getopt cmd :change-passwd))
|
||||||
(list-accounts (clingon:getopt cmd :list-accounts))
|
(la (clingon:getopt cmd :list-accounts))
|
||||||
(logging (clingon:getopt cmd :logging)))
|
(logging (clingon:getopt cmd :logging)))
|
||||||
(setf *debug* logging)
|
(setf *debug* logging)
|
||||||
(when list-accounts
|
(when la
|
||||||
(cli/list-accounts))
|
(cli/list-accounts))
|
||||||
(when ca
|
(when ca
|
||||||
(cli/create-account ca args))
|
(cli/create-account ca args))
|
||||||
(when change-passwd-account
|
(when pa
|
||||||
(cli/change-passwd change-passwd-account args))
|
(cli/change-passwd pa args))
|
||||||
(when repl
|
(when repl
|
||||||
(stderr "Running a REPL on localhost:4006...~%"))
|
(repl))
|
||||||
(when server
|
(when (and (not la) (not ca) (not pa))
|
||||||
(server-start))))
|
(server-start))))
|
||||||
|
|
||||||
(defun cli/command ()
|
(defun cli/command ()
|
||||||
(clingon:make-command
|
(clingon:make-command
|
||||||
:name "loop"
|
:name "loop"
|
||||||
:description "<<Description>>"
|
:description "<<Description>>"
|
||||||
:version "<<Version>>"
|
:version "<<Version>>" ;; :authors '("Circling Skies <loop@antartida.xyz>")
|
||||||
:authors '("Circling Skies <loop@antartida.xyz>")
|
|
||||||
:license "GPL v3"
|
:license "GPL v3"
|
||||||
:options (cli/options)
|
:options (cli/options)
|
||||||
:handler #'cli/main))
|
:handler #'cli/main))
|
||||||
@ %def cli/options cli/command
|
@ %def cli/options cli/command
|
||||||
|
|
||||||
\section{The request dispatching mechanism}
|
\section{Request dispatching mechanism}
|
||||||
|
|
||||||
Dispatching requests means consuming one and invoking the correct
|
Dispatching requests means consuming one and invoking the correct
|
||||||
procedure that will process the request. The invoked procedure must
|
procedure that will process the request. The invoked procedure must
|
||||||
|
@ -743,7 +755,7 @@ has issued {\tt QUIT}, in which case we terminate [[main-loop]].
|
||||||
(dispatch (parse-request (make-request :said ln))))
|
(dispatch (parse-request (make-request :said ln))))
|
||||||
@ %def dispatch dispatch-line
|
@ %def dispatch dispatch-line
|
||||||
|
|
||||||
\section{The representation and parsing of articles}
|
\section{Representation and parsing of articles}
|
||||||
|
|
||||||
An article is made of two parts, the head and the body. We do need to
|
An article is made of two parts, the head and the body. We do need to
|
||||||
parse the head, but we never parse the body: we don't want to
|
parse the head, but we never parse the body: we don't want to
|
||||||
|
@ -872,7 +884,7 @@ using [[lookup]]. I need to seek out all such places and organize. %% TODO
|
||||||
(cdr (assoc key table :test #'string=)))
|
(cdr (assoc key table :test #'string=)))
|
||||||
@ %def extract-mid lookup
|
@ %def extract-mid lookup
|
||||||
|
|
||||||
\section{The commands}
|
\section{Commands}
|
||||||
|
|
||||||
\subsection{{\tt HELP}}
|
\subsection{{\tt HELP}}
|
||||||
|
|
||||||
|
@ -1820,14 +1832,13 @@ noticeable. %%TODO
|
||||||
|
|
||||||
The NNTP protocol establishes that line termination is done with
|
The NNTP protocol establishes that line termination is done with
|
||||||
\verb|\r\n|, but it's useful to support UNIX line terminations, too,
|
\verb|\r\n|, but it's useful to support UNIX line terminations, too,
|
||||||
because we are using the command-line and interact directly with the
|
because we are using the command-line and interacting directly with
|
||||||
server using tools that will not always send \verb|\r\n| as line
|
the server using tools that will not always send \verb|\r\n| as line
|
||||||
termination. For example, when someone is typing directly from the
|
termination. For example, when someone is typing directly from the
|
||||||
keyboard and insert an empty line, we need the {\tt (and acc ...)}
|
keyboard and insert an empty line, we need the {\tt (and acc ...)}
|
||||||
because sometimes the list [[acc]] comes out empty. But an empty line
|
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
|
never comes from the NNTP protocol because there's is always a {\tt
|
||||||
CR} before {\tt LF}, but that's not true when someone is using the
|
CR} before {\tt LF}.
|
||||||
keyboard directly.
|
|
||||||
|
|
||||||
<<Command post>>=
|
<<Command post>>=
|
||||||
(defun nntp-read-line (&optional (s *standard-input*) acc)
|
(defun nntp-read-line (&optional (s *standard-input*) acc)
|
||||||
|
@ -1969,7 +1980,21 @@ all or it has been discussed with the community beforehand.
|
||||||
(values nil "must match <<Form of newsgroup names>>"))))
|
(values nil "must match <<Form of newsgroup names>>"))))
|
||||||
@ %def CREATE-GROUP group-name-conforms?
|
@ %def CREATE-GROUP group-name-conforms?
|
||||||
|
|
||||||
\section{The publication of news}
|
\subsection{{\tt REPL}}
|
||||||
|
|
||||||
|
Opens a REPL for the pleasure of hacking \lp. The only thing we
|
||||||
|
require is that the user be authenticated. This means that any user
|
||||||
|
has total control over \lp. XXX: implement an option
|
||||||
|
[[--disable-repl]] so that REPL hacking is turned off. (This would
|
||||||
|
mean your users are not true hackers.)
|
||||||
|
|
||||||
|
<<Command repl>>=
|
||||||
|
(defun cmd-repl (r)
|
||||||
|
(with-auth
|
||||||
|
(repl r)))
|
||||||
|
@
|
||||||
|
|
||||||
|
\section{Publication of news}
|
||||||
|
|
||||||
If you're interested in being notified about what's going on in the
|
If you're interested in being notified about what's going on in the
|
||||||
\lp, then subscribe to {\tt local.control.news}. Group creation,
|
\lp, then subscribe to {\tt local.control.news}. Group creation,
|
||||||
|
@ -2010,7 +2035,7 @@ invitations {\em et cetera} are published there.
|
||||||
:body (data body)))
|
:body (data body)))
|
||||||
@ %def notify-group-created notify-user-created
|
@ %def notify-group-created notify-user-created
|
||||||
|
|
||||||
\section{The algorithm of {\tt split-vector}}
|
\section{Algorithm of {\tt split-vector}}
|
||||||
|
|
||||||
How should we describe the algorithm of [[split-vector]]? The
|
How should we describe the algorithm of [[split-vector]]? The
|
||||||
objective is to consume lists of bytes such as
|
objective is to consume lists of bytes such as
|
||||||
|
@ -2041,7 +2066,7 @@ searching for the next line.
|
||||||
(+ pos (length delim))))))))
|
(+ pos (length delim))))))))
|
||||||
@ %def split-vector
|
@ %def split-vector
|
||||||
|
|
||||||
\section{The index article}\label{sec:index}
|
\section{Article index}\label{sec:index}
|
||||||
|
|
||||||
Every NNTP server needs to have an index of articles. Each article is
|
Every NNTP server needs to have an index of articles. Each article is
|
||||||
indexed by its message-id. For example, the article
|
indexed by its message-id. For example, the article
|
||||||
|
@ -2185,7 +2210,7 @@ doesn't really support symbolic links.
|
||||||
(values grp art))))
|
(values grp art))))
|
||||||
@ %def insert-index lookup-index
|
@ %def insert-index lookup-index
|
||||||
|
|
||||||
\section{A procedure to import the index from the file system}
|
\section{Procedure to import the index from the file system}
|
||||||
|
|
||||||
%% get group:
|
%% get group:
|
||||||
%% (first (last (pathname-directory (car (in-groups (directory "**/*"))))))
|
%% (first (last (pathname-directory (car (in-groups (directory "**/*"))))))
|
||||||
|
@ -2224,11 +2249,7 @@ we need to index it.
|
||||||
Here's a program to build the index from a UNIX shell.
|
Here's a program to build the index from a UNIX shell.
|
||||||
|
|
||||||
<<build-index-from-fs.lisp>>=
|
<<build-index-from-fs.lisp>>=
|
||||||
#-quicklisp
|
<<Quicklisp loading preamble>>
|
||||||
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
|
|
||||||
(user-homedir-pathname))))
|
|
||||||
(when (probe-file quicklisp-init)
|
|
||||||
(load quicklisp-init)))
|
|
||||||
(ql:quickload :loop :silent t)
|
(ql:quickload :loop :silent t)
|
||||||
(in-package #:loop)
|
(in-package #:loop)
|
||||||
(connect-index! "message-id.db")
|
(connect-index! "message-id.db")
|
||||||
|
@ -2266,11 +2287,7 @@ The program [[cron-remove-inactive-users.lisp]] can be executed every
|
||||||
day at midnight, say.
|
day at midnight, say.
|
||||||
|
|
||||||
<<cron-remove-inactive-users.lisp>>=
|
<<cron-remove-inactive-users.lisp>>=
|
||||||
#-quicklisp
|
<<Quicklisp loading preamble>>
|
||||||
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
|
|
||||||
(user-homedir-pathname))))
|
|
||||||
(when (probe-file quicklisp-init)
|
|
||||||
(load quicklisp-init)))
|
|
||||||
(ql:quickload :loop :silent t)
|
(ql:quickload :loop :silent t)
|
||||||
(in-package #:loop)
|
(in-package #:loop)
|
||||||
(read-accounts!)
|
(read-accounts!)
|
||||||
|
@ -2358,11 +2375,7 @@ New system administrators of \Lp\ will never need to run this.
|
||||||
Here's a program to run the migration in a UNIX shell.
|
Here's a program to run the migration in a UNIX shell.
|
||||||
|
|
||||||
<<migrate-add-creation-date.lisp>>=
|
<<migrate-add-creation-date.lisp>>=
|
||||||
#-quicklisp
|
<<Quicklisp loading preamble>>
|
||||||
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
|
|
||||||
(user-homedir-pathname))))
|
|
||||||
(when (probe-file quicklisp-init)
|
|
||||||
(load quicklisp-init)))
|
|
||||||
(ql:quickload :loop :silent t)
|
(ql:quickload :loop :silent t)
|
||||||
(in-package #:loop)
|
(in-package #:loop)
|
||||||
(migrate-add-creation-and-post-date!)
|
(migrate-add-creation-and-post-date!)
|
||||||
|
@ -2429,7 +2442,7 @@ Now we write the procedures that discover what accounts are inactive.
|
||||||
(user-inactive? (account-username u)))))
|
(user-inactive? (account-username u)))))
|
||||||
@ %def list-inactive-users
|
@ %def list-inactive-users
|
||||||
|
|
||||||
\section{A special-purpose language to ease writing}\label{sec:dsl}
|
\section{Macros to ease writing}\label{sec:dsl}
|
||||||
|
|
||||||
These macros make up a tiny language to ease the writing of \lp. For
|
These macros make up a tiny language to ease the writing of \lp. For
|
||||||
example, when we need to access the group database, we use
|
example, when we need to access the group database, we use
|
||||||
|
@ -2494,6 +2507,10 @@ stands for ``Universal Character Set'' and I speculate the number 2
|
||||||
means 2 bytes. So our conversion is just removing the first byte.
|
means 2 bytes. So our conversion is just removing the first byte.
|
||||||
|
|
||||||
<<Little procedures>>=
|
<<Little procedures>>=
|
||||||
|
(defun print/finish (&rest args)
|
||||||
|
(apply #'format (cons t args))
|
||||||
|
(finish-output))
|
||||||
|
|
||||||
(defun plural (v suffix)
|
(defun plural (v suffix)
|
||||||
(if (> v 1) suffix ""))
|
(if (> v 1) suffix ""))
|
||||||
|
|
||||||
|
@ -2506,7 +2523,8 @@ means 2 bytes. So our conversion is just removing the first byte.
|
||||||
|
|
||||||
(defun stderr (&rest args)
|
(defun stderr (&rest args)
|
||||||
(when *debug*
|
(when *debug*
|
||||||
(apply #'out (cons *error-output* args))))
|
(apply #'out (cons *error-output* args))
|
||||||
|
(finish-output *error-output*)))
|
||||||
|
|
||||||
(defun stdout (&rest args)
|
(defun stdout (&rest args)
|
||||||
(apply #'out (list* *standard-output* args)))
|
(apply #'out (list* *standard-output* args)))
|
||||||
|
@ -2587,11 +2605,7 @@ the code.
|
||||||
Just say {\tt make loop} to your shell.
|
Just say {\tt make loop} to your shell.
|
||||||
|
|
||||||
<<build-exe.lisp>>=
|
<<build-exe.lisp>>=
|
||||||
#-quicklisp
|
<<Quicklisp loading preamble>>
|
||||||
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
|
|
||||||
(user-homedir-pathname))))
|
|
||||||
(when (probe-file quicklisp-init)
|
|
||||||
(load quicklisp-init)))
|
|
||||||
(ql:quickload :loop)
|
(ql:quickload :loop)
|
||||||
(sb-ext:save-lisp-and-die #P"loop"
|
(sb-ext:save-lisp-and-die #P"loop"
|
||||||
:toplevel #'loop:main
|
:toplevel #'loop:main
|
||||||
|
@ -2599,6 +2613,14 @@ Just say {\tt make loop} to your shell.
|
||||||
:save-runtime-options t)
|
:save-runtime-options t)
|
||||||
@
|
@
|
||||||
|
|
||||||
|
<<Quicklisp loading preamble>>=
|
||||||
|
#-quicklisp
|
||||||
|
(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp"
|
||||||
|
(user-homedir-pathname))))
|
||||||
|
(when (probe-file quicklisp-init)
|
||||||
|
(load quicklisp-init)))
|
||||||
|
@ %def quicklisp
|
||||||
|
|
||||||
\section{How to get a log of \lp's communication}
|
\section{How to get a log of \lp's communication}
|
||||||
|
|
||||||
If you invoke \lxxp\ with option [[--logging]], you get logging on
|
If you invoke \lxxp\ with option [[--logging]], you get logging on
|
||||||
|
@ -2636,7 +2658,7 @@ specify in {\tt syslog.conf} the selector {\tt user.notice} and
|
||||||
specify a log file such as {\tt /var/log/loop.log}. See {\tt
|
specify a log file such as {\tt /var/log/loop.log}. See {\tt
|
||||||
syslog.conf(5)} and {\tt newsyslog(1)} for more information.
|
syslog.conf(5)} and {\tt newsyslog(1)} for more information.
|
||||||
|
|
||||||
\section{The package {\tt loop.lisp} as the compiler needs it}
|
\section{Package {\tt loop.lisp} as the compiler needs it}
|
||||||
|
|
||||||
We now put together all source code chunks in the order the compiler
|
We now put together all source code chunks in the order the compiler
|
||||||
needs to read it. One thing to keep in mind here is---I wonder if
|
needs to read it. One thing to keep in mind here is---I wonder if
|
||||||
|
@ -2673,6 +2695,7 @@ something to think about.
|
||||||
<<Table of commands>>
|
<<Table of commands>>
|
||||||
<<Macros>>
|
<<Macros>>
|
||||||
<<Little procedures>>
|
<<Little procedures>>
|
||||||
|
<<Loop's REPL>>
|
||||||
<<Procedures for requests and responses>>
|
<<Procedures for requests and responses>>
|
||||||
<<Essential operations relative to the index>>
|
<<Essential operations relative to the index>>
|
||||||
<<How to create and connect to the index>>
|
<<How to create and connect to the index>>
|
||||||
|
@ -2699,6 +2722,7 @@ something to think about.
|
||||||
<<Command passwd>>
|
<<Command passwd>>
|
||||||
<<Command users>>
|
<<Command users>>
|
||||||
<<Command dd>>
|
<<Command dd>>
|
||||||
|
<<Command repl>>
|
||||||
|
|
||||||
<<Broadcasting>>
|
<<Broadcasting>>
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue