diff --git a/Makefile b/Makefile index 1dbc8dc..0c4665d 100644 --- a/Makefile +++ b/Makefile @@ -1,79 +1,74 @@ -SHELL=/bin/sh -REMOTE=dbastos@antartida.xyz -REMOTE_LIB_PATH=quicklisp/local-projects -REMOTE_EXE_PATH=loop-test -SERVICE_NAME=loop-test - -default: - @echo "Sorry. You need to read the Makefile to know what I can make for you." - -all: loop.lisp build-exe.lisp exe run \ -migrate-add-creation-date.lisp cron-remove-inactive-users.lisp - -live: all remote-copy # remote-build-exe - -remote-copy: - scp loop.asd loop.lisp \ - $(REMOTE):$(REMOTE_LIB_PATH)/loop - scp build-exe.lisp \ - $(REMOTE):$(REMOTE_EXE_PATH)/ - scp migrate-add-creation-date.lisp \ - $(REMOTE):$(REMOTE_EXE_PATH)/ - scp cron-remove-inactive-users.lisp \ - $(REMOTE):$(REMOTE_EXE_PATH)/ - -sync-users: - scp $(REMOTE):$(REMOTE_EXE_PATH)/accounts.lisp . - -remote-build-exe: - plink -ssh $(REMOTE) cd $(REMOTE_EXE_PATH)/ && \ - sbcl --script build-exe.lisp && \ - echo "Executable built." - -remote-migrate-account-creation: - plink -ssh $(REMOTE) cd $(REMOTE_EXE_PATH)/ && \ - sbcl --script migrate-add-creation-date.lisp - -remote-cron-remove-inactive-users: - plink -ssh $(REMOTE) cd $(REMOTE_EXE_PATH)/ && \ - sbcl --script remote-cron-remove-inactive-users.lisp - -livedoc: - echo loop.nw | python peat -C 'make loop.pdf' - -run: loop.nw - (any tangle -Rrun < loop.nw > run.tmp || (rm run.tmp && exit 1)) && \ - mv run.tmp run.lisp && \ - chmod 0755 run - -loop.tex: loop.nw - any weave -delay -index loop.nw > loop.tex - -loop.pdf: loop.tex - latexmk -pdf loop - -loop.lisp: loop.nw - (any tangle -Rloop.lisp < loop.nw > loop.tmp || (rm loop.tmp && exit 1)) && \ - mv loop.tmp loop.lisp - -build-exe.lisp: loop.nw - (any tangle -Rbuild-exe.lisp < loop.nw > build-exe.tmp || (rm build-exe.tmp && exit 1)) && \ - mv build-exe.tmp build-exe.lisp - -build-index-from-fs.lisp: loop.nw - (any 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 build-index-from-fs.lisp - -cron-remove-inactive-users.lisp: loop.nw - (any 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 cron-remove-inactive-users.lisp - -migrate-add-creation-date.lisp: loop.nw - (any 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 migrate-add-creation-date.lisp - -exe: loop.lisp build-exe.lisp - sbcl --script build-exe.lisp && echo "Executable built okay." - -service: run - sudo ln -s $(pwd) /service/$(SERVICE_NAME) +default: + @echo "Sorry. See Makefile to know what I can make for you." + +all: loop loop.lisp loop.asd \ +scripts/build-exe.lisp \ +scripts/cron-remove-inactive-users.lisp \ +scripts/build-index-from-fs.lisp \ +scripts/migrate-add-creation-date.lisp + +clean: + rm -f *.pdf *.out *.aux *.log *.fls *.fdb_latexmk loop loop.tex + +build: loop.lisp loop.asd scripts/build-exe.lisp + # mkdir -p ~/quicklisp/local-projects/loop + # cmp loop.asd ~/quicklisp/local-projects/loop/loop.asd || \ + # cp loop.asd ~/quicklisp/local-projects/loop + # cmp loop.lisp ~/quicklisp/local-projects/loop/loop.lisp || \ + # cp loop.lisp ~/quicklisp/local-projects/loop + # cp loop.asd ~/quicklisp/local-projects/loop + # cp loop.lisp ~/quicklisp/local-projects/loop + sbcl --script scripts/build-exe.lisp + +install: loop + mkdir -p `head -1 conf-home` && \ + cp -R loop accounts.lisp groups scripts `head -1 conf-home` + +loop: loop.lisp scripts/build-exe.lisp + sbcl --script scripts/build-exe.lisp + +loop.lisp: loop.nw + (any tangle -Rloop.lisp < loop.nw > loop.tmp || \ + (rm loop.tmp && exit 1)) && \ + mv loop.tmp loop.lisp + +loop.asd: loop.nw + (any 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.nw + (any 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 > \ + 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 > \ + 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 + +migrate-add-creation-date.lisp: loop.nw + (any 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 > run.tmp || (rm run.tmp && exit 1)) && \ + mv run.tmp run && \ + chmod 0755 run + +loop.tex: loop.nw + any weave -delay -index loop.nw > loop.tex + +loop.pdf: loop.tex + latexmk -pdf loop diff --git a/README b/README new file mode 100644 index 0000000..8d0dc73 --- /dev/null +++ b/README @@ -0,0 +1,103 @@ +(*) Introduction + +LOOP is an NNTP server written in Common Lisp. + +(*) Assumptions + +We assume + + - you run SBCL + + - you have Quicklisp installed and knows how to use it + + - you know how to use a TCP server such as + + https://cr.yp.to/ucspi-tcp.html + + - you know how to manage a daemon with + + https://cr.yp.to/daemontools.html + + - you have git and knows how to use it + +(*) How to install it + +LOOP is not in the Quicklisp repository, so we'll instruct you to +install it as a local project. Go to + + ~/quicklisp/local-projects/ + +and say + + git clone https://git.antartida.xyz/loop/srv + cd srv + make build + +Now you have the executable loop. Try it out: + +--8<-------------------------------------------------------->8--- +$ ./loop --help +NAME: + loop - An NNTP server for a circle of friends. + +USAGE: + loop [options] [arguments ...] + +OPTIONS: + --change-passwd changes password + --create-account creates a new account + --help display usage information and exit + --logging turn on debug logging on stderr + --version display version and exit + -l, --list-accounts lists accounts + -r, --repl run a REPL on port 4006 + -s, --server runs NNTP server reading from stdout + +AUTHORS: + Circling Skies + +LICENSE: + GPL v3 +--8<-------------------------------------------------------->8--- + +You can talk to the NNTP server with -s: + +--8<-------------------------------------------------------->8--- +$ ./loop -s +200 Welcome! Say ``help'' for a menu. +quit +205 Good-bye. +--8<-------------------------------------------------------->8--- + +So now have your system run your TCP server of choice. For instance, +if you're using djb's tcpserver and would like LOOP to listen on port +1024, say + +--8<-------------------------------------------------------->8--- +$ tcpserver -v -HR 0.0.0.0 1024 ./loop -s +tcpserver: status: 0/40 +--8<-------------------------------------------------------->8--- + +Using another terminal, telnet to your host on port 1024: + +--8<-------------------------------------------------------->8--- +$ telnet localhost 1024 +Trying 127.0.0.1... +Connected to antartida.xyz. +Escape character is '^]'. +200 Welcome! Say ``help'' for a menu. +quit +205 Good-bye. +Connection closed by foreign host. +--8<-------------------------------------------------------->8--- + +Directory daemon/ in LOOP's source code has sample scripts to use with +djb's tcpserver and daemontools. If you never done this, it will be +better education if you learn to use daemontools and ucspi-tcp before +going live with LOOP community. It's easy and fun. + +(*) Create your account + +Accounts are kept in accounts.lisp. Create a first account with + + ./loop --create-account you diff --git a/accounts.lisp b/accounts.lisp index cadd35b..4f8ea66 100644 --- a/accounts.lisp +++ b/accounts.lisp @@ -1,9 +1,36 @@ (#S(LOOP::ACCOUNT + :USERNAME "TOIS" + :SEEN NIL + :LAST-POST NIL + :FRIENDS NIL + :PASS 2668758003445446799 + :PASS-LOCKED NIL + :PASS-LOCKED-WHY NIL + :CREATION 3942774377) + #S(LOOP::ACCOUNT + :USERNAME "ME" + :SEEN NIL + :LAST-POST NIL + :FRIENDS NIL + :PASS 4516159621457714044 + :PASS-LOCKED NIL + :PASS-LOCKED-WHY NIL + :CREATION 3942774136) + #S(LOOP::ACCOUNT + :USERNAME "YOU" + :SEEN NIL + :LAST-POST NIL + :FRIENDS NIL + :PASS 619654876836234945 + :PASS-LOCKED NIL + :PASS-LOCKED-WHY NIL + :CREATION 3942774072) + #S(LOOP::ACCOUNT :USERNAME "ANONYMOUS" :SEEN 3935609919 :LAST-POST NIL - :FRIENDS NIL + :FRIENDS ("TOIS" "ME" "YOU") :PASS 2335603191554807875 :PASS-LOCKED NIL :PASS-LOCKED-WHY NIL - :CREATION 3913066800)) + :CREATION 3913066800)) \ No newline at end of file diff --git a/build-exe.lisp b/build-exe.lisp deleted file mode 100644 index cf687f8..0000000 --- a/build-exe.lisp +++ /dev/null @@ -1,5 +0,0 @@ -(load "~/.sbclrc") -(ql:quickload :loop :silent t) -(sb-ext:save-lisp-and-die #P"loop.exe" - :toplevel #'loop:main - :executable t) diff --git a/build-index-from-fs.lisp b/build-index-from-fs.lisp deleted file mode 100644 index 531c769..0000000 --- a/build-index-from-fs.lisp +++ /dev/null @@ -1,7 +0,0 @@ -(load "~/.sbclrc") -(ql:quickload :loop :silent t) -(in-package #:loop) -(connect-index! "message-id.db") -(remake-index!) -(index-from-fs!) -(format t "Index built.~%") diff --git a/conf-home b/conf-home new file mode 100644 index 0000000..7fcd045 --- /dev/null +++ b/conf-home @@ -0,0 +1,4 @@ +~/loop + +The executable and the ucspi-tcp-tcpserver service will be installed +at this directory. diff --git a/cron-remove-inactive-users.lisp b/cron-remove-inactive-users.lisp deleted file mode 100644 index 788c1ba..0000000 --- a/cron-remove-inactive-users.lisp +++ /dev/null @@ -1,8 +0,0 @@ -(load "~/.sbclrc") -(ql:quickload :loop :silent t) -(in-package #:loop) -;; (format t *default-pathname-defaults*) -(read-accounts!) -(connect-index! "message-id.db") -(remove-inactive-users!) -(write-accounts!) diff --git a/groups/local.control.news/2 b/groups/local.control.news/2 deleted file mode 100644 index 8fb0618..0000000 --- a/groups/local.control.news/2 +++ /dev/null @@ -1,7 +0,0 @@ -Date: 2024-12-05 07:27:01 GMT-3 -Message-Id: -From: Loop -Subject: account HIMMEL removed by Loop -Newsgroups: local.control.news - -HIMMEL didn't log in a first time (for 1 month) since account creation. diff --git a/groups/local.control.news/3 b/groups/local.control.news/3 deleted file mode 100644 index 9efd2e1..0000000 --- a/groups/local.control.news/3 +++ /dev/null @@ -1,7 +0,0 @@ -Date: 2024-12-05 07:52:39 GMT-3 -Message-Id: -From: Loop -Subject: account HIMMEL removed by Loop -Newsgroups: local.control.news - -HIMMEL didn't log in a first time (for 1 month) since account creation. diff --git a/groups/local.control.news/4 b/groups/local.control.news/4 deleted file mode 100644 index 5108f91..0000000 --- a/groups/local.control.news/4 +++ /dev/null @@ -1,7 +0,0 @@ -Date: 2024-12-05 07:52:39 GMT-3 -Message-Id: -From: Loop -Subject: account MFELIX locked by Loop -Newsgroups: local.control.news - -MFELIX disappeared for over 3 months. diff --git a/groups/local.control.news/5 b/groups/local.control.news/5 deleted file mode 100644 index 6b578e6..0000000 --- a/groups/local.control.news/5 +++ /dev/null @@ -1,7 +0,0 @@ -Date: 2024-12-05 07:52:39 GMT-3 -Message-Id: -From: Loop -Subject: account KIMOCHI locked by Loop -Newsgroups: local.control.news - -KIMOCHI disappeared for over 3 months. diff --git a/groups/local.control.news/6 b/groups/local.control.news/6 deleted file mode 100644 index ffe4546..0000000 --- a/groups/local.control.news/6 +++ /dev/null @@ -1,7 +0,0 @@ -Date: 2024-12-05 07:52:39 GMT-3 -Message-Id: -From: Loop -Subject: account WILLIAMP locked by Loop -Newsgroups: local.control.news - -WILLIAMP disappeared for over 3 months. diff --git a/groups/local.control.news/7 b/groups/local.control.news/7 deleted file mode 100644 index a1f976f..0000000 --- a/groups/local.control.news/7 +++ /dev/null @@ -1,7 +0,0 @@ -Date: 2024-12-05 07:52:39 GMT-3 -Message-Id: -From: Loop -Subject: account JPMAB locked by Loop -Newsgroups: local.control.news - -JPMAB disappeared for over 3 months. diff --git a/groups/local.test/1.~1~ b/groups/local.test/1.~1~ deleted file mode 100644 index 014728f..0000000 --- a/groups/local.test/1.~1~ +++ /dev/null @@ -1,7 +0,0 @@ -Date: 2024-03-07 21:44:31 GMT-3 -Message-Id: -From: Loop -Subject: let there be light -Newsgroups: local.control.news - -A sample group. diff --git a/loop.asd b/loop.asd index 3b6a768..1769ead 100644 --- a/loop.asd +++ b/loop.asd @@ -1,14 +1,7 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*- (asdf:defsystem :loop :version "0.1" - :description "An NNTP server written in Lisp for a circle of friends." - :depends-on (:lisp-unit - :str - :uiop - :cl-fad - :cl-ppcre - :local-time - :iterate - :clsql-sqlite3) + :description "An NNTP server for a circle of friends." + :depends-on (:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon + :filesystem-utils) :components ((:file "loop"))) - diff --git a/loop.lisp b/loop.lisp index 4ea3067..74ed88c 100644 --- a/loop.lisp +++ b/loop.lisp @@ -1,14 +1,8 @@ ;;; -*- mode: LISP; syntax: COMMON-LISP; package: LOOP; -*- (eval-when (:compile-toplevel :load-toplevel :execute) (ql:quickload - '(:lisp-unit - :str - :uiop - :cl-fad - :cl-ppcre - :local-time - :iterate - :clsql-sqlite3) + '(:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon + :filesystem-utils) :silent t)) (clsql:enable-sql-reader-syntax) @@ -16,11 +10,108 @@ (defpackage #:loop (:use :common-lisp :local-time) (:import-from :lisp-unit define-test) - (:import-from :iterate iter) + (:import-from :org.shirakumo.filesystem-utils directory-p list-directories) (:export :main)) (in-package #:loop) +(defun cli/command () + (clingon:make-command + :name "loop" + :description "An NNTP server for a circle of friends." + :version "0.1" + :authors '("Circling Skies ") + :license "GPL v3" + :options (cli/options) + :handler #'cli/main)) + +(defun cli/options () + (list + (clingon:make-option + :string + :description " creates a new account" + :long-name "create-account" + :key :create-account) + (clingon:make-option + :string + :description " changes password" + :long-name "change-passwd" + :key :change-passwd) + (clingon:make-option + :flag + :description "lists accounts" + :short-name #\l + :long-name "list-accounts" + :key :list-accounts) + (clingon:make-option + :flag + :description "runs NNTP server reading from stdout" + :short-name #\s + :long-name "server" + :key :server) + (clingon:make-option + :flag + :description "run a REPL on port 4006" + :short-name #\r + :long-name "repl" + :key :repl) + (clingon:make-option + :flag + :description "turn on debug logging on stderr" + :long-name "logging" + :key :logging))) +(defun cli/list-accounts () + (println (str:join (crlf-string) (list-users)))) + +(defun cli/create-account (username args) + (let ((invited-by (car args))) + (cond ((null invited-by) + (println "Must specify who invites the new account.")) + ((get-account username) + (println "Username account ``~a'' already exists." username)) + ((not (get-account invited-by)) + (println "Invited-by account ``~a'' doesn't exist." invited-by)) + (t + (multiple-value-bind (okay? pass-or-error) (new-account! username invited-by) + (if okay? + (progn (println "Okay, account ``~a'' created with password ``~a''." + username pass-or-error) + (notify-user-created username)) + (println "Sorry, ~a." pass-or-error))))))) + +(defun cli/change-passwd (username args) + (let* ((random-passwd (random-string 6)) + (given-passwd (car args)) + (new-passwd (or given-passwd random-passwd))) + (if (not (get-account change-passwd-account)) + (println "No such account ``~a''." change-passwd-account) + (multiple-value-bind (okay? problem) (change-passwd! change-passwd-account new-passwd) + (if okay? + (println "Okay, account ~a now has password ``~a''." change-passwd-account new-passwd) + (println "Sorry, could not change password: ~a." problem)))))) +(defvar *debug* nil) +(defun cli/main (cmd) + (read-accounts!) + (connect-index! "message-id.db") + (create-index!) + (let ((args (clingon:command-arguments cmd)) + (repl (clingon:getopt cmd :repl)) + (server (clingon:getopt cmd :server)) + (ca (clingon:getopt cmd :create-account)) + (change-passwd-account (clingon:getopt cmd :change-passwd)) + (list-accounts (clingon:getopt cmd :list-accounts)) + (logging (clingon:getopt cmd :logging))) + (setf *debug* logging) + (when list-accounts + (cli/list-accounts)) + (when ca + (cli/create-account ca args)) + (when change-passwd-account + (cli/change-passwd change-passwd-account args)) + (when repl + (stderr "Running a REPL on localhost:4006...~%")) + (when server + (server-start)))) (defun remove-inactive-users! () (loop for u in *accounts* do (let ((username (account-username u))) @@ -45,21 +136,19 @@ (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 - (delete-if #'(lambda (x) (equal x username)) (account-friends u))) - (delete-if #'(lambda (x) (equal username (account-username x))) *accounts*)) + (setf (account-friends u) + (delete username (account-friends u) :test #'equal))) + (setf *accounts* + (delete-if #'(lambda (a) (equal (account-username a) username)) + *accounts*))) (defun lock-account! (username why) (let ((u (get-account username))) (setf (account-pass-locked u) (account-pass u)) (setf (account-pass u) "locked") (setf (account-pass-locked-why u) why))) - -(defun remove-friend (username friend) - (remove-if #'(lambda (x) (equal x friend)) - (account-friends (get-account username)))) (defparameter *months-inactive-allowed* 3) (defparameter *months-never-logged-in* 1) @@ -132,7 +221,7 @@ (clsql:execute-command "create unique index if not exists idx_id_1 on indices (id)")) -(defun remake-index! () +(defun drop-create-index! () (clsql:execute-command "drop table if exists indices") (create-index!)) (defun insert-index (m g i) @@ -163,15 +252,22 @@ (defun plural (v suffix) (if (> v 1) "s" "")) -(defun debug? () nil) - (eval-when (:compile-toplevel :load-toplevel :execute) (defun fmt (cstr &rest args) (apply #'format nil (list* cstr args)))) +(defun out (stream &rest args) + (apply #'format (cons stream args))) + (defun stderr (&rest args) - (when (debug?) - (apply #'format (cons *error-output* args)))) + (when *debug* + (apply #'out (cons *error-output* args)))) + +(defun stdout (&rest args) + (apply #'out (list* *standard-output* args))) + +(defun println (&rest args) + (apply #'out (list* *standard-output* (str:concat (car args) "~%") (cdr args)))) (defun enumerate (ls &optional (first-index 0)) (loop for e in ls and i from first-index @@ -366,14 +462,15 @@ (defun request-quit? (r) (and r (string= 'quit (request-verb r)))) (defun response-quit? (r) (and r (request-quit? (response-request r)))) -(defun main () - (send-banner!) +(defun server-start () (set-up-tables!) - (read-accounts!) - (connect-index! "message-id.db") - (create-index!) + (send-banner!) (main-loop)) +(defun main () + (let ((app (cli/command))) + (clingon:run app))) + (defun send-banner! () (send-response! (make-response :code 200 :data "Welcome! Say ``help'' for a menu."))) @@ -627,10 +724,10 @@ (defun group? (g) (in-groups - (cl-fad:directory-exists-p g))) + (directory-p g))) (defun xgroup? (g) - (cl-fad:directory-exists-p g)) + (directory-p g)) (defun set-group! (g) (setf (client-group *client*) g)) @@ -680,7 +777,7 @@ ;; though, we'll not be using directories. That's a ;; problem to be studied. (let ((as (articles->integers - (remove-if #'temporary-article? (cl-fad:list-directory g))))) + (remove-if #'temporary-article? (list-directories (truename g)))))) (sort (remove-if-not #'(lambda (x) (between? x (or from x) (or to x))) as) @@ -701,7 +798,7 @@ ls))) (defun list-groups () - (let ((groups (in-groups (cl-fad:list-directory ".")))) + (let ((groups (in-groups (list-directories (truename "."))))) (sort (mapcar #'(lambda (g) (basename (uiop:unix-namestring g))) groups) #'string-lessp))) @@ -954,7 +1051,7 @@ (with-n-args 1 r (let* ((args (mapcar #'str:upcase (request-args r))) (username (car args))) - (multiple-value-bind (username pass-or-error) (new-account! username) + (multiple-value-bind (username pass-or-error) (new-account! username (client-username *client*)) (if (not username) (make-response :code 400 :request r :data (fmt "~a. Choose a new name." pass-or-error)) @@ -975,7 +1072,7 @@ (setq *accounts* (read s)))) *accounts*) -(defun new-account! (username) +(defun new-account! (username invited-by) (let* ((u (str:upcase username)) (p (random-string 6)) (a (make-account :username u @@ -983,8 +1080,8 @@ :creation (get-universal-time)))) (if (get-account u) (values nil (fmt "account ~a already exists" u)) - (let ((c (get-account (client-username *client*)))) - (push u (account-friends c)) + (progn + (push u (account-friends (get-account invited-by))) (push a *accounts*) (write-accounts!) (values (str:upcase username) p))))) @@ -1190,5 +1287,5 @@ (insert-index m g i))))) (defun remake-index-from-fs () - (remake-index!) + (drop-create-index!) (index-from-fs!)) diff --git a/loop.nw b/loop.nw index 00f8d2a..ff1cd5c 100644 --- a/loop.nw +++ b/loop.nw @@ -7,7 +7,7 @@ \usepackage[T1]{fontenc} \usepackage[utf8]{inputenc} \usepackage{csquotes} -\usepackage[brazil]{babel} +\usepackage{babel} \usepackage{etoolbox} \AtBeginEnvironment{quote}{\small} @@ -16,14 +16,14 @@ %% \usepackage[backend=biber]{biblatex} %% \addbibresource{refs.bib} %% \renewcommand{\cite}{\parencite} -\usepackage[hyperref]{xcolor} +% \usepackage[hyperref]{xcolor} \usepackage[colorlinks=true,citecolor=]{hyperref} % linkcolor=red \usepackage{amsmath,amsthm,amssymb} \allowdisplaybreaks \usepackage{lmodern} \usepackage{noweb} -\noweboptions{brazil,longchunks,smallcode} +\noweboptions{longchunks,smallcode} \DeclareMathOperator{\mdc}{mdc} \DeclareMathOperator{\gcdext}{gcdext} \DeclareMathOperator{\remainder}{remainder} @@ -359,6 +359,18 @@ 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 through the command line as illustrated in Section~\ref{sec:design}. +\section{The description of the package} + +<>= +An NNTP server for a circle of friends. +@ + +<>= +0.1 +@ + +These chunks are used in [[loop.asd]]. + \section{The representation of a client} How do we represent a client? A client is typically reading a group @@ -557,19 +569,143 @@ itself---so we can cascade actions based on a user's request. (defun request-quit? (r) (and r (string= 'quit (request-verb r)))) (defun response-quit? (r) (and r (request-quit? (response-request r)))) -(defun main () - (send-banner!) +(defun server-start () (set-up-tables!) - (read-accounts!) - (connect-index! "message-id.db") - (create-index!) + (send-banner!) (main-loop)) +(defun main () + (let ((app (cli/command))) + (clingon:run app))) + (defun send-banner! () (send-response! (make-response :code 200 :data "Welcome! Say ``help'' for a menu."))) @ %def main main-loop +\section{Command-line parsing} + +We're using the clingon library as per Vincent Dardel suggestion in +``The Common Lisp Cookbook''. (Thanks, Vincent!) 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. + +<>= +(defun cli/command () + (clingon:make-command + :name "loop" + :description "<>" + :version "<>" + :authors '("Circling Skies ") + :license "GPL v3" + :options (cli/options) + :handler #'cli/main)) + +(defun cli/options () + (list + (clingon:make-option + :string + :description " creates a new account" + :long-name "create-account" + :key :create-account) + (clingon:make-option + :string + :description " changes password" + :long-name "change-passwd" + :key :change-passwd) + (clingon:make-option + :flag + :description "lists accounts" + :short-name #\l + :long-name "list-accounts" + :key :list-accounts) + (clingon:make-option + :flag + :description "runs NNTP server reading from stdout" + :short-name #\s + :long-name "server" + :key :server) + (clingon:make-option + :flag + :description "run a REPL on port 4006" + :short-name #\r + :long-name "repl" + :key :repl) + (clingon:make-option + :flag + :description "turn on debug logging on stderr" + :long-name "logging" + :key :logging))) +@ + +The command-line options form a language. The user specifies +everything he wants with flags. If he wants nothing, for instance, he +specifies nothing and then nothing happens. XXX: I'd like to have a +default action (which would be running the server) that is invoked by +default if none of the other options would run. But I don't know how +to do that yet. + +<>= +(defun cli/list-accounts () + (println (str:join (crlf-string) (list-users)))) + +(defun cli/create-account (username args) + (let ((invited-by (car args))) + (cond ((null invited-by) + (println "Must specify who invites the new account.")) + ((get-account username) + (println "Username account ``~a'' already exists." username)) + ((not (get-account invited-by)) + (println "Invited-by account ``~a'' doesn't exist." invited-by)) + (t + (multiple-value-bind (okay? pass-or-error) (new-account! username invited-by) + (if okay? + (progn (println "Okay, account ``~a'' created with password ``~a''." + username pass-or-error) + (notify-user-created username)) + (println "Sorry, ~a." pass-or-error))))))) + +(defun cli/change-passwd (username args) + (let* ((random-passwd (random-string 6)) + (given-passwd (car args)) + (new-passwd (or given-passwd random-passwd))) + (if (not (get-account change-passwd-account)) + (println "No such account ``~a''." change-passwd-account) + (multiple-value-bind (okay? problem) (change-passwd! change-passwd-account new-passwd) + (if okay? + (println "Okay, account ~a now has password ``~a''." change-passwd-account new-passwd) + (println "Sorry, could not change password: ~a." problem)))))) +@ + +Now let's write the main procedure in command-line parsing. + +<>= +(defvar *debug* nil) +(defun cli/main (cmd) + (read-accounts!) + (connect-index! "message-id.db") + (create-index!) + (let ((args (clingon:command-arguments cmd)) + (repl (clingon:getopt cmd :repl)) + (server (clingon:getopt cmd :server)) + (ca (clingon:getopt cmd :create-account)) + (change-passwd-account (clingon:getopt cmd :change-passwd)) + (list-accounts (clingon:getopt cmd :list-accounts)) + (logging (clingon:getopt cmd :logging))) + (setf *debug* logging) + (when list-accounts + (cli/list-accounts)) + (when ca + (cli/create-account ca args)) + (when change-passwd-account + (cli/change-passwd change-passwd-account args)) + (when repl + (stderr "Running a REPL on localhost:4006...~%")) + (when server + (server-start)))) +@ %def cli/options cli/command + \section{The request dispatching mechanism} Dispatching requests means consuming one and invoking the correct @@ -728,7 +864,8 @@ Lisp offers me [[labels]], but [[labels]] don't seem so helpful when I'm at the REPL. When I use [[defun]], I'm able to always invoke the 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.} %% TODO +reason to think we're doing to debug it.} XXX: replace menu with +[[loop]]. <>= (defun cmd-help (r) @@ -803,16 +940,10 @@ Syntax error. Say ``authinfo USER /your-name/'' then ``authinfo PASS /your-pass/ \subsection{{\tt CREATE-ACCOUNT}} -We allow authenticated members to invite their friends. - -%% A propósito, estamos removendo a conta {\tt ROOT} de exibição. O que -%% significa que {\tt ROOT} não nem mesmo se conectar ao \Lp. Se -%% desejarmos que {\tt ROOT} se conecte, talvez a gente possa fazer -%% código especialmente pra gerenciar a conta dele. Fazemos assim pra -%% não permitir que usuários tenham qualquer chance de -%% -%% (remove-if #'(lambda (u) (equal "ROOT" (account-username u))) -%% (read s)) +We allow authenticated members to invite their friends. Notice that +we're not doing any kind of checking on the username. XXX: take a +look at how we verify group names match a certain regex and apply the +same check here. <>= (defun cmd-create-account (r) @@ -820,7 +951,7 @@ We allow authenticated members to invite their friends. (with-n-args 1 r (let* ((args (mapcar #'str:upcase (request-args r))) (username (car args))) - (multiple-value-bind (username pass-or-error) (new-account! username) + (multiple-value-bind (username pass-or-error) (new-account! username (client-username *client*)) (if (not username) (make-response :code 400 :request r :data (fmt "~a. Choose a new name." pass-or-error)) @@ -841,7 +972,7 @@ We allow authenticated members to invite their friends. (setq *accounts* (read s)))) *accounts*) -(defun new-account! (username) +(defun new-account! (username invited-by) (let* ((u (str:upcase username)) (p (random-string 6)) (a (make-account :username u @@ -849,12 +980,12 @@ We allow authenticated members to invite their friends. :creation (get-universal-time)))) (if (get-account u) (values nil (fmt "account ~a already exists" u)) - (let ((c (get-account (client-username *client*)))) - (push u (account-friends c)) + (progn + (push u (account-friends (get-account invited-by))) (push a *accounts*) (write-accounts!) (values (str:upcase username) p))))) -@ %def CREATE-ACCOUNT +@ %def CREATE-ACCOUNT new-account! Notice that we have a race condition in [[write-accounts]]. What is the problem? Two processes in parallel may ask for the writing of @@ -1099,7 +1230,7 @@ even cache the overview of the group.) %% TODO ;; though, we'll not be using directories. That's a ;; problem to be studied. (let ((as (articles->integers - (remove-if #'temporary-article? (cl-fad:list-directory g))))) + (remove-if #'temporary-article? (list-directories (truename g)))))) (sort (remove-if-not #'(lambda (x) (between? x (or from x) (or to x))) as) @@ -1120,7 +1251,7 @@ even cache the overview of the group.) %% TODO ls))) (defun list-groups () - (let ((groups (in-groups (cl-fad:list-directory ".")))) + (let ((groups (in-groups (list-directories (truename "."))))) (sort (mapcar #'(lambda (g) (basename (uiop:unix-namestring g))) groups) #'string-lessp))) @@ -1157,10 +1288,10 @@ We just need to verify if the group exists and modify [[*client*]]. (defun group? (g) (in-groups - (cl-fad:directory-exists-p g))) + (directory-p g))) (defun xgroup? (g) - (cl-fad:directory-exists-p g)) + (directory-p g)) (defun set-group! (g) (setf (client-group *client*) g)) @@ -1860,10 +1991,10 @@ specify anything. (clsql:execute-command "create unique index if not exists idx_id_1 on indices (id)")) -(defun remake-index! () +(defun drop-create-index! () (clsql:execute-command "drop table if exists indices") (create-index!)) -@ %def create-index! remake-index! connect-index! +@ %def create-index! drop-create-index! connect-index! Of course, the creation and connection of the index must occur before [[main-loop]], so it takes place in [[main]]. @@ -1986,19 +2117,23 @@ we need to index it. (insert-index m g i))))) (defun remake-index-from-fs () - (remake-index!) + (drop-create-index!) (index-from-fs!)) @ Here's a program to build the index from a UNIX shell. <>= -(load "~/.sbclrc") +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) (ql:quickload :loop :silent t) (in-package #:loop) (connect-index! "message-id.db") -(remake-index!) -(index-from-fs) +(drop-create-index!) +(index-from-fs!) (format t "Index built.~%") @ @@ -2019,21 +2154,25 @@ Index built. \section{Deletion and locking of inactive accounts}\label{sec:inactive-users} -In [[remove-friend]], note that [[username]] is the account name and -[[friend]] is the name of the account being removed. Notice as well -that we only know who invited the person after we can get a hold of -the account in [[accounts.lisp]]. This means we must scan each -account to delete an account---we can't delete an account and still -leave the account as someone's friend. +XXX: remove this paragraph from here; present the program first and +then talk about it. In [[remove-friend]], note that [[username]] is +the account name and [[friend]] is the name of the account being +removed. Notice as well that we only know who invited the person +after we can get a hold of the account in [[accounts.lisp]]. This +means we must scan each account to delete an account---we can't delete +an account and still leave the account as someone's friend. The program [[cron-remove-inactive-users.lisp]] can be executed every day at midnight, say. <>= -(load "~/.sbclrc") +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) (ql:quickload :loop :silent t) (in-package #:loop) -;; (format t *default-pathname-defaults*) (read-accounts!) (connect-index! "message-id.db") (remove-inactive-users!) @@ -2069,22 +2208,33 @@ with [[setf]]. %% TODO (fmt "disappeared for over ~a months" *months-inactive-allowed*)) (format t "Locked ~a due to long-time-no-see.~%" username)))))) +@ %def remove-inactive-users! +To remove an account, we need to first remove the username (to be +removed) from anyone's list of friends. So, this involves scanning +the entire list of accounts. Also, notice that delete ``may modify +{\em sequence}''. More importantly is to understand tha we really +must {\tt setf} the return, otherwise we might find the deletion did +not take effect---for example, when deleting the first element of a +list. (This deserves a better explanation, but if you know how linked +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 - (delete-if #'(lambda (x) (equal x username)) (account-friends u))) - (delete-if #'(lambda (x) (equal username (account-username x))) *accounts*)) + (setf (account-friends u) + (delete username (account-friends u) :test #'equal))) + (setf *accounts* + (delete-if #'(lambda (a) (equal (account-username a) username)) + *accounts*))) (defun lock-account! (username why) (let ((u (get-account username))) (setf (account-pass-locked u) (account-pass u)) (setf (account-pass u) "locked") (setf (account-pass-locked-why u) why))) - -(defun remove-friend (username friend) - (remove-if #'(lambda (x) (equal x friend)) - (account-friends (get-account username)))) -@ %def remove-account! remove-friend +@ %def remove-account! Accounts that do not have a creation date up until today---Tue Sep 17 21:37:18 ESAST 2024---will have its creation dates migrated to the @@ -2108,7 +2258,11 @@ New system administrators of \Lp\ will never need to run this. Here's a program to run the migration in a UNIX shell. <>= -(load "~/.sbclrc") +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) (ql:quickload :loop :silent t) (in-package #:loop) (migrate-add-creation-and-post-date!) @@ -2240,15 +2394,22 @@ means 2 bytes. So our conversion is just removing the first byte. (defun plural (v suffix) (if (> v 1) "s" "")) -(defun debug? () nil) - (eval-when (:compile-toplevel :load-toplevel :execute) (defun fmt (cstr &rest args) (apply #'format nil (list* cstr args)))) +(defun out (stream &rest args) + (apply #'format (cons stream args))) + (defun stderr (&rest args) - (when (debug?) - (apply #'format (cons *error-output* args)))) + (when *debug* + (apply #'out (cons *error-output* args)))) + +(defun stdout (&rest args) + (apply #'out (list* *standard-output* args))) + +(defun println (&rest args) + (apply #'out (list* *standard-output* (str:concat (car args) "~%") (cdr args)))) (defun enumerate (ls &optional (first-index 0)) (loop for e in ls and i from first-index @@ -2320,18 +2481,28 @@ the code. \section{How to produce the binary executable} -Just say {\tt make exe} to your shell. +Just say {\tt make loop} to your shell. <>= -(load "~/.sbclrc") +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) (ql:quickload :loop :silent t) -(sb-ext:save-lisp-and-die #P"loop.exe" +(sb-ext:save-lisp-and-die #P"loop" :toplevel #'loop:main - :executable t) + :executable t + :save-runtime-options t) @ \section{How to update the remote server}\label{sec:live} +XXX: notice we don't include such targets in the [[Makefile]] +anymore. Now we use a [[Makefile.personal]] that we don't release +anymore. We may still keep this section as instruction, but we need +to update it to reflect the facts. + We automate here the process of updating and compilation of a new version of \lp. It's certain that what we document here is specific to a single UNIX system, but what's important is that you (dear @@ -2417,18 +2588,16 @@ variables in the chunks where it's used. But for someone reading global variables at the top of the file. That's something to think about. +<>= +:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon +:filesystem-utils +@ + <>= ;;; -*- mode: LISP; syntax: COMMON-LISP; package: LOOP; -*- (eval-when (:compile-toplevel :load-toplevel :execute) (ql:quickload - '(:lisp-unit - :str - :uiop - :cl-fad - :cl-ppcre - :local-time - :iterate - :clsql-sqlite3) + '(<>) :silent t)) (clsql:enable-sql-reader-syntax) @@ -2436,11 +2605,12 @@ about. (defpackage #:loop (:use :common-lisp :local-time) (:import-from :lisp-unit define-test) - (:import-from :iterate iter) + (:import-from :org.shirakumo.filesystem-utils directory-p list-directories) (:export :main)) (in-package #:loop) +<> <> <> <> @@ -2487,37 +2657,58 @@ about. <>= ;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*- (asdf:defsystem :loop - :version "0.0.1" - :description "An NNTP server for a group of friends." - :depends-on (:lisp-unit :str :uiop :cl-fad :cl-ppcre) + :version "<>" + :description "<>" + :depends-on (<>) :components ((:file "loop"))) -@ %def :loop +@ %def :loop loop.asd \section{The UNIX service} +XXX: this section should be informative only. We're going to suggest +users how to run the system. We may provide a [[make install]] target +that runs things the way we do, but this should be optional. Idea: +instead of hard coding a path to the service, make it {\tt conf-home} +or {\tt conf-service}. + +The installation is as follows. You clone the repo to your +local-projects, then run make build. This builds the executable. You +edit conf-home to choose your install directory. Then you say make +install which copies loop, accounts.lisp, the scripts and the service +directory. It is now the syadmin duty to do ln -s ./svc to +/service/loop, which runs it. Let's see if we can pull that off. + We use the {\tt tcpserver} program by Daniel J. Bernstein from the package \href{https://cr.yp.to/ucspi-tcp.html}{\tt ucspi-tcp}. -<>= -/home/dbastos/loop -@ %def - <>= 119 @ %def <>= #!/bin/sh +home=`head -1 conf-home` +cd $home +exec 2>1& echo loop -cd <> -exec <>/tcpserver -HR 0.0.0.0 <> <>/loop.exe +exec "$home"/tcpserver -HR 0.0.0.0 <> "$home"/loop @ %def -How should you update the server if you modified the source-code? See -Section~\ref{sec:live}. +<>= +#!/bin/sh +echo loop +exec /usr/bin/logger -i -t loop +@ \section{The writing process} +XXX: note to self. Targets [[make build]] and [[make install]] must +be completely non-dependent on noweb. Also, most users will not run +any web at all---they'll run noweb, so releasing {\tt any} use in the +Makefile makes no sense to users. I think we'll need to set up a +virtual machine to practice the use of real-world noweb for other +users. (Lots of work!) + The program {\tt latexmk} is iseful when I'm writing \LaTeX\ in general, but to get the attention of {\tt latexmk} we need to rewrite {\tt loop.tex}. So what I do while writing \lp\ is to have a diff --git a/scripts/build-exe.lisp b/scripts/build-exe.lisp new file mode 100644 index 0000000..19a536b --- /dev/null +++ b/scripts/build-exe.lisp @@ -0,0 +1,10 @@ +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) +(ql:quickload :loop :silent t) +(sb-ext:save-lisp-and-die #P"loop" + :toplevel #'loop:main + :executable t + :save-runtime-options t) diff --git a/scripts/build-index-from-fs.lisp b/scripts/build-index-from-fs.lisp new file mode 100644 index 0000000..592a19f --- /dev/null +++ b/scripts/build-index-from-fs.lisp @@ -0,0 +1,11 @@ +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) +(ql:quickload :loop :silent t) +(in-package #:loop) +(connect-index! "message-id.db") +(drop-create-index!) +(index-from-fs!) +(format t "Index built.~%") diff --git a/scripts/cron-remove-inactive-users.lisp b/scripts/cron-remove-inactive-users.lisp new file mode 100644 index 0000000..b652d62 --- /dev/null +++ b/scripts/cron-remove-inactive-users.lisp @@ -0,0 +1,11 @@ +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) +(ql:quickload :loop :silent t) +(in-package #:loop) +(read-accounts!) +(connect-index! "message-id.db") +(remove-inactive-users!) +(write-accounts!) diff --git a/scripts/migrate-add-creation-date.lisp b/scripts/migrate-add-creation-date.lisp new file mode 100644 index 0000000..da38081 --- /dev/null +++ b/scripts/migrate-add-creation-date.lisp @@ -0,0 +1,9 @@ +#-quicklisp +(let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" + (user-homedir-pathname)))) + (when (probe-file quicklisp-init) + (load quicklisp-init))) +(ql:quickload :loop :silent t) +(in-package #:loop) +(migrate-add-creation-and-post-date!) +(format t "Accounts rewritten.~%")