From 847c11ad95c862c7293065f3564640d049dfcab8 Mon Sep 17 00:00:00 2001 From: Circling Skies Date: Sat, 8 Feb 2025 17:00:12 -0300 Subject: [PATCH] Writes index in the UNIX way. Adds support for TAGS in noweb files. I really don't know whether the above is complete or not. --- Makefile | 2 +- Anyfile => Nowebfile | 40 +- TAGS | 291 +++++++++++++ format-def | 0 loop.lisp | 315 ++++++++------ loop.nw | 538 +++++++++++++++--------- make-release | 0 scripts/build-index-from-fs.lisp | 1 - scripts/cron-remove-inactive-users.lisp | 1 - 9 files changed, 816 insertions(+), 372 deletions(-) rename Anyfile => Nowebfile (61%) create mode 100644 TAGS mode change 100644 => 100755 format-def mode change 100644 => 100755 make-release diff --git a/Makefile b/Makefile index 7b81a2e..c34dbb5 100644 --- a/Makefile +++ b/Makefile @@ -5,5 +5,5 @@ loop: loop.asd loop.lisp scripts/build-exe.lisp install: loop mkdir -p `head -1 conf-home` && \ - cp -R loop accounts.lisp groups scripts \ + cp -R loop accounts.lisp index groups scripts \ `head -1 conf-home` diff --git a/Anyfile b/Nowebfile similarity index 61% rename from Anyfile rename to Nowebfile index 8fbd929..33dffbf 100644 --- a/Anyfile +++ b/Nowebfile @@ -3,79 +3,81 @@ include Makefile default: all -all: loop.exe loop.lisp loop.asd scripts/build-exe.lisp \ +all: loop loop.lisp loop.asd scripts/build-exe.lisp \ scripts/build-index-from-fs.lisp \ scripts/cron-remove-inactive-users.lisp \ scripts/migrate-add-creation-date.lisp -loop.exe: scripts/build-exe.lisp loop.lisp loop.asd loop.nw +loop: 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 < loop.nw > format-def.tmp || \ (rm format-def.tmp && exit 1)) && \ - mv format-def.tmp format-def + mv format-def.tmp format-def && \ + chmod 0755 format-def make-release: loop.nw - (any tangle -Rmake-release < loop.nw | \ - dos2unix > make-release.tmp || \ + (no tangle -Rmake-release < loop.nw > make-release.tmp || \ (rm make-release.tmp && exit 1)) && \ - mv make-release.tmp make-release + mv make-release.tmp make-release && \ + chmod 0755 make-release release: make-release ./make-release $$(git log --oneline -1 | awk '{print $$1}') \ 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 || \ + (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 \ + rm -f loop loop.asd loop.lisp loop.tex loop.pdf \ *.fasl *.db .*~ *~ *.out *.aux *.log *.fls *.fdb_latexmk + +tags: loop.nw + etags -l tex loop.nw + etags -a -l lisp loop.nw diff --git a/TAGS b/TAGS new file mode 100644 index 0000000..2bed1b4 --- /dev/null +++ b/TAGS @@ -0,0 +1,291 @@ + +loop.nw,3549 +\def\nwendcode{\nwendcode35,939 +\newcommand{\lxxp}\lxxp39,1017 +\newcommand{\Lp}\Lp40,1048 +\newcommand{\lp}\lp41,1077 +\newcommand{\bug}\bug42,1099 +\newcommand{\symlink}\symlink43,1128 +\newcommand{\symlinks}\symlinks44,1171 + \label{fg:gnus}fg:gnus81,2706 + \label{fg:bird}fg:bird87,2911 + \label{fg:sylpheed}fg:sylpheed93,3111 +\ref{fg:gnus}fg:gnus137,5733 +\section*{*140,5822 +Section \ref{sec:inactive-users}sec:inactive-users148,6361 +\section*{*184,8177 +\section{Implementation strategy}\label{sec:design}Implementation190,8309 +illustrated in Figures~\ref{fg:gnus}fg:gnus319,12489 +Section~\ref{sec:repl}sec:repl323,12758 +\section{NNTP protocol}NNTP328,12991 +\section{It's a network server}It's342,13733 +through the command line as illustrated in Section~\ref{sec:design}sec:design369,15205 +\section{REPL for \lp}\label{sec:repl}REPL371,15275 +\section{Representation of a client}Representation437,17373 +\section{Representation of a command}Representation449,17769 +\section{Representation of requests and responses}Representation517,20742 +\section{Main loop}Main594,23952 +\section{Parsing of requests}Parsing668,25894 +\section{Parsing of command-line arguments}Parsing687,26655 +\section{Request dispatching mechanism}Request956,36835 +\section{Representation and parsing of articles}Representation977,37628 +\section{How to extract articles from the database}How1056,40692 +\section{Commands}Commands1106,42494 +\subsection{{\tt HELP}}1108,42514 +\subsection{{\tt AUTHINFO}}\label{sec:authinfo}1142,43799 +Section~\ref{sec:login}sec:login1148,44091 +\subsection{{\tt CREATE-ACCOUNT}}1193,45783 +\subsection{{\tt UNLOCK-ACCOUNT}}1311,50341 +\ref{sec:inactive-users}sec:inactive-users1314,50430 +\subsection{{\tt LOGIN}}\label{sec:login}1347,51741 +Besides {\tt AUTHINFO} in Section~\ref{sec:authinfo}sec:authinfo1349,51784 +\subsection{{\tt PASSWD}}\label{sec:passwd}1375,52745 +\subsection{{\tt USERS}}\label{sec:users}1421,54619 +\subsection{{\tt LIST}}\label{sec:list}1471,56270 +\subsection{{\tt GROUP}}\label{sec:group}1623,62335 +\subsection{{\tt BODY}, {\tt HEAD}, {\tt ARTICLE} e {\tt NEXT}}1653,63159 +\label{sec:typical-cmds}sec:typical-cmds1654,63223 +Section~\ref{sec:index}sec:index1664,63791 +\subsection{{\tt XOVER}}\label{sec:xover}1766,68395 +\subsection{{\tt MODE READER}}\label{sec:mode-reader}1824,70966 +\subsection{{\tt DATE}}\label{sec:date}1833,71213 +\subsection{{\tt QUIT}}\label{sec:quit}1846,71556 +\subsection{{\tt DD}}\label{sec:dd}1856,71819 +\subsection{{\tt POST}}\label{sec:post}1868,72221 +\subsection{{\tt CREATE-GROUP}}2224,87356 +\subsection{{\tt REPL}}2261,89096 +\section{Publication of news}Publication2288,89946 +\section{Algorithm of {\tt split-vector}}Algorithm2329,91508 +\section{Article index}\label{sec:index}Article2360,92703 +\section{Essential operations relative to the index}Essential2455,97073 +\section{Procedure to import the index from the file system}Procedure2498,98728 +\section{Deletion and locking of inactive accounts}\label{sec:inactive-users}Deletion2561,100684 +\section{Macros to ease writing}\label{sec:dsl}Macros2728,107298 +\section{Other procedures}Other2791,109436 +\section{Tests}Tests2881,112192 +\section{Executable, how to build it}Executable,2955,115097 +\section{Log of \lp's communication, how to produce it}Log2976,115677 +\section{Package {\tt loop.lisp} as the compiler needs it}Package3013,117026 +\section{Other source code}Other3115,120122 +\section*{*3195,122671 +\section*{*3198,122712 + +loop.nw,7305 +(defun repl 406,16343 +(defstruct client 444,17634 +(defparameter *client* 445,17706 +(defstruct command 460,18265 +(defparameter *commands-assoc* 461,18305 +(defun table-of-commands 465,18368 +(defun set-up-tables! 490,19685 +(defun get-command 503,20181 +(defstruct request 532,21442 +(defstruct response 533,21477 +(defun empty-response 537,21574 +(defun prepend-response-with 538,21653 +(defun append-crlf-if-needed 549,22043 +(defun send-response! 559,22363 +(defun my-write 588,23775 +(defun main-loop 609,24653 +(defun request-quit? 617,24876 +(defun response-quit? 618,24943 +(defun server-start 620,25016 +(defun main 625,25091 +(defun send-banner! 632,25233 +(defun parse-request 675,26144 +(defun root/command 716,28117 +(defun root/options 725,28344 +(defun root/handlers 744,28795 +(defun root/main 809,31474 +(defun account/command 824,31972 +(defun account/options 831,32139 +(defun account/manager 875,33168 +(defun account/list-accounts 924,35337 +(defun account/create-account! 927,35421 +(defun account/change-passwd! 943,36207 +(defun dispatch 967,37362 +(defun dispatch-line 973,37517 +(defstruct article 998,38720 +(defun parse-article 1002,38784 +(defun hs-space-collapsed 1006,38965 +(defun hs-lines 1009,39081 +(defun parse-header 1011,39139 +(defun parse-headers 1024,39630 +(defun string-integer? 1028,39756 +(defun get-header-from-article 1035,39991 +(defun get-header 1038,40099 +(defun fetch-headers 1042,40205 +(defun enrich-headers 1048,40421 +(defun nlines 1053,40603 +(defun fetch-article 1064,41049 +(defun read-file-raw 1068,41136 +(defun fetch-body 1079,41431 +(defun encode-body 1090,41887 +(defun extract-mid 1100,42298 +(defun lookup 1102,42398 +(defun cmd-help 1123,43298 +(defun menu 1131,43561 +(defun display-fn 1135,43639 +(defun cmd-authinfo 1158,44464 +(defun authinfo-check 1180,45447 +(defun auth? 1183,45516 +(defun log-user-in! 1186,45570 +(defun user-name-conforms? 1213,46445 +(defun cmd-create-account 1217,46550 +(defstruct account 1234,47320 +(defparameter *accounts* 1235,47414 +(defun read-accounts! 1239,47491 +(defun string->array 1247,47688 +(defun string->sha256 1252,47849 +(defun new-account! 1256,47997 +(defun write-accounts! 1289,49613 +(defun get-account 1305,50135 +(defun cmd-unlock-account 1318,50539 +(defun unlock-account! 1335,51329 +(defun cmd-login 1355,52064 +(defun log-user-in-as! 1370,52632 +(defun cmd-passwd 1382,53017 +(defun pass? 1401,53919 +(defun change-passwd! 1412,54342 +(defun cmd-list-users 1427,54763 +(defun size-of-longest-username 1435,54990 +(defun list-users 1439,55105 +(defun universal-to-human 1459,55939 +(defun last-time-seen 1465,56058 +(defstruct group 1481,56720 +(defun cmd-list 1483,56753 +(defun build-groups-lines 1490,57013 +(defun build-groups-structs 1497,57177 +(defun between? 1504,57442 +(defun filesize 1508,57517 +(defun zero-file? 1512,57589 +(defun temporary-article? 1515,57640 +(defun article-ready? 1519,57749 +(defun get-articles 1524,57866 +(defun group-high-low 1534,58254 +(defun articles->integers 1541,58481 +(defun list-groups 1548,58718 +(defun last-char 1553,58915 +(defun basename 1561,59128 +(defun loop-directory* 1582,60148 +(defun loop-list-files 1592,60810 +(defun loop-list-directories 1601,61165 +(defun cmd-group 1628,62466 +(defun group? 1639,62876 +(defun xgroup? 1643,62946 +(defun set-group! 1646,62986 +(defun typical-cmd-head-body-article 1667,63887 +(defun cmd-head 1683,64754 +(defun cmd-body 1685,64827 +(defun cmd-article 1687,64900 +(defun article-response 1690,64980 +(defun head-response 1692,65079 +(defun body-response 1694,65195 +(defun typical-cmd-response 1723,66781 +(defun cmd-next 1744,67563 +(defun article-next! 1755,68017 +(defun mid-by-name 1762,68284 +(defun cmd-xover 1775,68756 +(defun xover 1794,69713 +(defun xover-format-line 1815,70635 +(defun xover-headers 1820,70857 +(defun cmd-mode 1829,71112 +(defun cmd-date 1839,71400 +(defun cmd-quit 1852,71733 +(defun cmd-dd 1864,72114 +(defun suggest-message-id 1880,72765 +(defun random-string 1883,72857 +(defun unparse-article 1897,73270 +(defun ensure-header 1914,73886 +(defun get-date 1927,74369 +(defun ensure-mid 1934,74611 +(defun ensure-date 1936,74690 +(defun cmd-post 1964,75771 +(defun post 1998,77338 +(defun newsgroups-header->list 2020,78438 +(defun update-last-post-date! 2035,79134 +(defun rename-no-extension 2053,80063 +(defun save-article-try 2056,80166 +(defun save-article-insist 2084,81134 +(defun get-next-article-id 2090,81408 +(defun nntp-read-article 2106,82107 +(defun nntp-read-line 2125,82983 +(defun list->bytes 2134,83346 +(defun vector->bytes 2137,83400 +(defun data->bytes 2140,83469 +(defun add-crlf-between 2148,83738 +(defun string->bytes 2152,83890 +(defun bytes->string 2155,83945 +(defun conforms? 2177,84969 +(defun text/plain? 2190,85624 +(defun headers-required-from-clients 2199,85967 +(defun cmd-create-group 2234,87805 +(defun group-name-conforms? 2257,88972 +(defun cmd-repl 2267,89249 +(defparameter *enable-nntp-repl* 2285,89906 +(defun notify-group-created 2295,90179 +(defun notify-user-created 2300,90390 +(defun notify-user-unlocked 2305,90588 +(defun post-notification 2311,90805 +(defun make-news 2317,91098 +(defun split-vector 2340,92004 +(defun split-vector-helper 2344,92146 +(defparameter *default-database* 2391,93939 +(defun connect-index! 2395,94048 +(defun create-index! 2398,94167 +(defun drop-create-index! 2404,94414 +(defun insert-index 2471,97843 +(defun lookup-index 2487,98372 +(defun index-from-fs! 2520,99565 +(defun remake-index-from-fs 2529,99978 +(defun remove-inactive-users! 2586,101650 +(defun remove-account! 2622,103553 +(defun lock-account! 2630,103845 +(defun loop-epoch 2646,104579 +(defun migrate-add-creation-and-post-date! 2649,104640 +(defparameter *months-inactive-allowed* 2671,105406 +(defparameter *months-never-logged-in* 2672,105449 +(defun user-inactive? 2676,105535 +(defun inactive-from-never-logged-in? 2680,105661 +(defun locked? 2687,105915 +(defun inactive-from-last-post? 2690,106002 +(defun inactive-from-last-seen? 2698,106360 +(defun inactive-from? 2707,106709 +(defun ever-logged-in? 2715,106916 +(defun never-logged-in? 2718,106992 +(defun list-inactive-users 2721,107064 +(defmacro in-dir 2736,107574 +(defmacro in-groups 2750,108093 +(defun in-group-lambda 2752,108155 +(defmacro in-group 2754,108211 +(defmacro with-group 2757,108311 +(defmacro with-n-args 2767,108639 +(defmacro with-group-set 2777,109016 +(defmacro with-auth 2784,109221 +(defun conforms-to? 2802,109968 +(defun print/finish 2809,110219 +(defun word-plural 2813,110305 +(defun plural 2820,110556 +(defun out 2827,110740 +(defun stderr 2830,110811 +(defun stdout 2835,110937 +(defun println 2838,111013 +(defun enumerate 2841,111125 +(defun ucs-2->ascii 2845,111242 +(defun bad-input 2849,111339 +(defun integer->string 2852,111436 +(defun mkstr 2855,111487 +(defun data 2859,111592 +(defun crlf 2862,111675 +(defun crlf-string 2865,111709 +(defun flatten 2868,111775 +(defmacro mac 2877,112061 +(define-test dispatching2912,113895 +(defun unix->nntp 2915,113990 +(defvar a-post 2919,114102 +(defvar a-bad-post 2927,114251 +(define-test post-wrong-newsgroup2935,114446 +(define-test post-okay2940,114613 +(defpackage #:loop3037,118108 +(defparameter *debug* 3086,119338 +(asdf:defsystem :<>3108,119953 diff --git a/format-def b/format-def old mode 100644 new mode 100755 diff --git a/loop.lisp b/loop.lisp index bb7543a..4a1b7da 100644 --- a/loop.lisp +++ b/loop.lisp @@ -5,8 +5,6 @@ :filesystem-utils :ironclad/digest/sha256) :silent t)) -(clsql:file-enable-sql-reader-syntax) - (defpackage #:loop (:use :common-lisp :local-time) (:import-from :lisp-unit define-test assert-true) @@ -24,7 +22,6 @@ (defparameter *client* (make-client)) (defstruct request verb args said) (defstruct response code data request multi-line) -(defparameter *default-database* nil) (defstruct command fn verb description) (defparameter *commands-assoc* nil) (defstruct article headers body) @@ -283,42 +280,25 @@ :args args)))))) (defun insert-index (m g i) - (handler-case - (clsql:insert-records - :into "indices" - :attributes '(id grp article) - :values (list (str:trim m) (str:trim g) (str:trim i))) - (clsql-sys:sql-database-data-error (c) - (cond ((= (slot-value c 'clsql-sys::error-id) 19) - 'already-indexed) - (t - ; We should log this error. - ;(format t "other error: ~a" (slot-value c 'clsql-sys::database-message)) - 'sql-error))) - (:no-error () - nil))) + (let ((from (fmt "index/~a" m)) + (to (fmt "../groups/~a/~a" g i))) + (create-symbolic-link from to))) (defun lookup-index (mid) - (let* ((found (clsql:select [grp] [article] - :from [indices] - :where [= [id] (str:trim mid)])) - (article (first found)) - (grp (first article)) - (art (second article))) - (when found - (values grp art)))) - -(defun connect-index! (filename) - (setq *default-database* (clsql:connect (list filename) :database-type :sqlite3))) + (let ((path (ignore-errors (truename (fmt "index/~a" mid))))) + (when path + (let* ((name (namestring path)) + (pair (last (str:split "/" name) 2))) + (values (car pair) (cadr pair)))))) (defun create-index! () - (clsql:execute-command "create table if not exists indices - (id varchar(1000), grp varchar(1000), article varchar(300))") - (clsql:execute-command "create unique index if not exists idx_id_1 - on indices (id)")) + (ensure-directories-exist "index/")) + +(defun rm-rf (path) + (uiop:delete-directory-tree (pathname path) :validate t)) (defun drop-create-index! () - (clsql:execute-command "drop table if exists indices") + (rm-rf "index/") (create-index!)) (defun remove-inactive-users! () @@ -1133,21 +1113,19 @@ (defun write-accounts! () (let ((name - (loop - (let* ((tmp (random-string 10)) - (name (format nil "~a.tmp" tmp))) - (when - (ignore-errors - (with-open-file - (s name - :direction :output - :if-exists :error - :if-does-not-exist :create) - (write *accounts* :stream s))) - (return name)))))) - (if (ignore-errors (rename-file name "accounts.lisp")) - (values t *accounts*) - (values nil (format nil "could not rename ~a to accounts.lisp" name))))) + (let* ((tmp (random-string 10)) + (name (format nil "~a.tmp" tmp))) + (with-open-file + (s name + :direction :output + :if-exists :error + :if-does-not-exist :create) + (write *accounts* :stream s) + name)))) + (rename-file name "accounts.lisp") + (values t *accounts*) + ;(values nil (format nil "could not rename ~a to accounts.lisp" name)) + )) (defun get-account (username) (loop for u in *accounts* @@ -1251,23 +1229,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 @@ -1325,45 +1304,147 @@ ("newsgroups" . "local.control.news"))))) :body (data body))) -(defun cli/options () +(defun root/command () + (clingon:make-command + :name "LOOP" + :description "An NNTP server for a circle of friends." + :version "a89e088" + :options (root/options) + :handler #'root/handlers + :sub-commands (list (account/command)))) + +(defun root/options () (list - (clingon:make-option - :string - :description "creates a new account" - :long-name "create-account" - :key :create-account) - (clingon:make-option - :string - :description "changes password" - :long-name "change-passwd" - :key :change-passwd) (clingon:make-option :flag - :description "lists accounts" - :short-name #\l - :long-name "list-accounts" - :key :list-accounts) - (clingon:make-option - :flag - :description "runs a REPL right now" + :description "action: runs a REPL on the terminal" :short-name #\r :long-name "repl" :key :repl) (clingon:make-option :flag - :description "disables the NNTP REPL" + :description "action: disables the NNTP REPL" :long-name "disable-nntp-repl" :key :disable-nntp-repl) (clingon:make-option :flag - :description "logging (on stderr)" + :description "action: logs to stderr" :long-name "logging" :key :logging))) -(defun cli/list-accounts () +(defun root/handlers (cmd) + (handler-case + (root/main cmd) + (end-of-file () + (print/finish "^d~%") + (uiop:quit 0)) + (interactive-interrupt () + (print/finish "^c~%") + (uiop:quit 0)))) + +(defun root/main (cmd) + (let ((args (clingon:command-arguments cmd)) + (repl? (clingon:getopt cmd :repl)) + (logging? (clingon:getopt cmd :logging)) + (disable-nntp-repl? (clingon:getopt cmd :disable-nntp-repl))) + (setq *debug* logging?) + (setq *enable-nntp-repl* (not disable-nntp-repl?)) + (when repl? + (return-from root/main (repl (make-request)))) + (server-start))) + +(defun account/command () + (clingon:make-command + :name "account" + :description "manages accounts" + :options (account/options) + :handler #'account/manager)) + +(defun account/options () + (list + (clingon:make-option + :flag + :description "action: creates a new --username account invited by --invited-by" + :short-name #\n + :long-name "new" + :key :new) + (clingon:make-option + :flag + :description "action: lists all accounts" + :short-name #\l + :long-name "list" + :key :list) + (clingon:make-option + :string + :description "action: sets password for --username" + :short-name #\p + :long-name "password" + :key :password) + (clingon:make-option + :string + :description "" + :short-name #\u + :long-name "username" + :key :username) + (clingon:make-option + :string + :description "" + :short-name #\i + :long-name "invited-by" + :key :inviter) + (clingon:make-option + :flag + :description "action: destroys account --username" + :short-name #\d + :long-name "delete" + :key :del?))) + +(defun account/manager (cmd) + (let ((args (clingon:command-arguments cmd)) + (new? (clingon:getopt cmd :new)) + (del? (clingon:getopt cmd :del?)) + (list? (clingon:getopt cmd :list)) + (pass (clingon:getopt cmd :password)) + (user (str:upcase (clingon:getopt cmd :username))) + (inviter (clingon:getopt cmd :inviter))) + (cond + (pass + (cond ((not user) + (return-from account/manager + (println "Option --username is required."))) + (t (account/change-passwd! user pass) + ;(println "Okay, ~a has now password ``~a''" user pass) + ))) + (del? + (cond ((not user) + (return-from account/manager + (println "Option --username is required."))) + ((not (get-account user)) + (return-from account/manager + (println "Account ~a not found." user))) + (t (remove-account! user) + (write-accounts!) + (println "Account ~a deleted." user)))) + (new? + (cond ((or (not user) (not inviter)) + (return-from account/manager + (println "Options --username, --invited-by are required."))) + ((not (user-name-conforms? user)) + (return-from account/manager + (println "Username ``~a'' doesn't conform to regex /^[^\\s]+$/." user))) + ((not (get-account inviter)) + (return-from account/manager + (println "Inviter ~a is not a known account; list'em all with ``account -l''." inviter))) + (t + (log-user-in-as! inviter) + (account/create-account! user (list inviter))))) + (list? (account/list-accounts)) + (t (println "Nothing to do. Say --help."))))) + +(defun account/list-accounts () (println (str:join (crlf-string) (list-users)))) -(defun cli/create-account (username args) +(defun account/create-account! (username args) (let ((invited-by (car args))) (cond ((null invited-by) (println "Must specify who invites the new account.")) @@ -1379,62 +1460,15 @@ (notify-user-created username)) (println "Sorry, ~a." pass-or-error))))))) -(defun cli/change-passwd (username args) +(defun account/change-passwd! (username &optional given-passwd) (let* ((random-passwd (random-string 6)) - (given-passwd (car args)) (new-passwd (or given-passwd random-passwd))) (if (not (get-account username)) (println "No such account ``~a''." username) - (multiple-value-bind (okay? problem) (change-passwd! username new-passwd) (if okay? + (multiple-value-bind (okay? problem) (change-passwd! username new-passwd) + (if okay? (println "Okay, account ~a now has password ``~a''." username new-passwd) - (println "Sorry, could not change password: ~a." problem)))))) - -(defun cli/main-with-handlers (cmd) - (handler-case - (cli/main cmd) - (end-of-file () - (print/finish "^D~%") - (uiop:quit 0)) - (interactive-interrupt () - (print/finish "^C~%") - (uiop:quit 0)))) - -(defun cli/main (cmd) - (read-accounts!) - (connect-index! "message-id.db") - (create-index!) - (let ((args (clingon:command-arguments cmd)) - (run-server t) - (repl (clingon:getopt cmd :repl)) - (ca (clingon:getopt cmd :create-account)) - (pa (clingon:getopt cmd :change-passwd)) - (la (clingon:getopt cmd :list-accounts)) - (logging (clingon:getopt cmd :logging)) - (disable-nntp-repl (clingon:getopt cmd :disable-nntp-repl))) - (setf *debug* logging) - (when (or ca pa la) - (setf run-server nil)) - (when la - (cli/list-accounts)) - (when ca - (cli/create-account ca args)) - (when pa - (cli/change-passwd pa args)) - (when repl - (repl (make-request :verb "repl" :args '(command-line)))) - (when disable-nntp-repl - (setq *enable-nntp-repl* nil)) - (when run-server - (server-start)))) - -(defun cli/command () - (clingon:make-command - :name "loop" - :description "An NNTP server for a circle of friends." - :version "a89e088" - :license "GPL v3" - :options (cli/options) - :handler #'cli/main-with-handlers)) + (println "Sorry, could not change password: ~a." problem)))))) (defun main-loop () (loop @@ -1454,7 +1488,9 @@ (main-loop)) (defun main () - (let ((app (cli/command))) + (read-accounts!) + (create-index!) + (let ((app (root/command))) (clingon:run app))) (defun send-banner! () @@ -1493,7 +1529,6 @@ A bad test from the biggest mouth of the south. (define-test post-okay (read-accounts!) - (connect-index! "test.db") (create-index!) (setq *client* (make-client :username "ROOT" :auth? 'yes)) (multiple-value-bind (code msg) (post (string->bytes a-post)) diff --git a/loop.nw b/loop.nw index 6188016..7a125bd 100644 --- a/loop.nw +++ b/loop.nw @@ -623,7 +623,9 @@ itself---so we can cascade actions based on a user's request. (main-loop)) (defun main () - (let ((app (cli/command))) + (read-accounts!) + (create-index!) + (let ((app (root/command))) (clingon:run app))) (defun send-banner! () @@ -684,57 +686,244 @@ letters are equivalent in request verbs. \section{Parsing of command-line arguments} 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 Common Lisp Cookbook''. I'd like to thank the library's author, +Marin Atanasov Nikolov, for his attention while I was learning to use +the library. + +The library elegantly supports subcommands, of which we will take +advantage. Let's not dissertate too much what we're implementing +because this is likely a very unstable part of the system---that is, +we'll likely add many more options, switches and commands. Let's +content ourselves---for now---with explaining the design of the +library restrictly to our current needs. + +I'm thinking of the design of the library as a tree of commands. You +begin at the root command, which is the \lxxp\ executable itself. +From the root command, other subcommands will spring---for example, +{\tt account} for handling user account matters such as creating an +account or changing a password. This capability allows us to design +various programs into a single one. Let's begin, therefore, with the +root command and then we connect all the others. + +The [[main]] procedure is not here because we already have a section +called ``main loop'', so perhaps that's a better place to put \Lp's +main entry point. The main procedure will invoke [[root/command]]. +Attached to a command are the options and the handlers of the options. +In the root command, there's also a list of subcommands. <>= -(defun cli/options () +(defun root/command () + (clingon:make-command + :name "<>" + :description "<>" + :version "<>" + :options (root/options) + :handler #'root/handlers + :sub-commands (list (account/command)))) + +(defun root/options () (list - (clingon:make-option - :string - :description "creates a new account" - :long-name "create-account" - :key :create-account) - (clingon:make-option - :string - :description "changes password" - :long-name "change-passwd" - :key :change-passwd) (clingon:make-option :flag - :description "lists accounts" - :short-name #\l - :long-name "list-accounts" - :key :list-accounts) - (clingon:make-option - :flag - :description "runs a REPL right now" + :description "action: runs a REPL on the terminal" :short-name #\r :long-name "repl" :key :repl) (clingon:make-option :flag - :description "disables the NNTP REPL" + :description "action: disables the NNTP REPL" :long-name "disable-nntp-repl" :key :disable-nntp-repl) (clingon:make-option :flag - :description "logging (on stderr)" + :description "action: logs to stderr" :long-name "logging" :key :logging))) -@ -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 root/handlers (cmd) + (handler-case + (root/main cmd) + (end-of-file () + (print/finish "^d~%") + (uiop:quit 0)) + (interactive-interrupt () + (print/finish "^c~%") + (uiop:quit 0)))) +@ %def root/command + +You've already see root options above and next you'll see options and +flags for subcommands, so let me explain how I see the command line. +The command line is a language with which we program what we want the +system to do. If a certain action requires a username, for example, +do expect to issue an option such as {\tt --username john}. For a +more complete example, suppose you're going to create a new account +for user {\tt peter}. Certainly there will be {\tt --username peter} +in the command line; the subcommand for account creation is {\tt + account}, so we're looking at a command line such as {\tt ./loop + account --username peter}. But the subcommand {\tt account} houses +many commands such as one for creating an account, another for +changing a password and so on. So we're missing the account {\em + action} in that command line. The complete solution is {\tt ./loop + account --new --username peter --invited-by root}. Where did that +{\tt --invited-by} come from? It turns out account creation has this +extra requirement---every account must be associated to an account +holder. The system demands a tree of users. You would discover the +requirement by trying the wrong command line: +% +\begin{verbatim} +%./loop account --new --username peter +Options --username, --invited-by are required. +\end{verbatim} + +The way to familiarize yourself with the language to instruct +\Lp\ what to do is to say {\tt --help} to the root command and all +subcommands. When an option has no description, that means that +option is merely part of another option. In the help below, you can +see that {\tt --invited-by} has no description, but it is mentioned by +the {\tt --new} option. +% +\begin{verbatim} +%./loop account --help +NAME: + LOOP account - manages accounts + +USAGE: + LOOP [global-options] account [options] [arguments ...] + +OPTIONS: + --help display usage information and exit + --version display version and exit + -d, --delete destroys account --username + -i, --invited-by + -l, --list lists all accounts + -n, --new creates a new --username account invited by --invited-by + -p, --password sets password for --username + -u, --username +\end{verbatim} + +Let's describe the actions of the root command. Every command has to +have a certain main procedure. So this is it for the root command. <>= -(defun cli/list-accounts () +(defun root/main (cmd) + (let ((args (clingon:command-arguments cmd)) + (repl? (clingon:getopt cmd :repl)) + (logging? (clingon:getopt cmd :logging)) + (disable-nntp-repl? (clingon:getopt cmd :disable-nntp-repl))) + (setq *debug* logging?) + (setq *enable-nntp-repl* (not disable-nntp-repl?)) + (when repl? + (return-from root/main (repl (make-request)))) + (server-start))) +@ %def root/main + +We continue with the {\tt account} subcommand. + +<>= +(defun account/command () + (clingon:make-command + :name "account" + :description "manages accounts" + :options (account/options) + :handler #'account/manager)) + +(defun account/options () + (list + (clingon:make-option + :flag + :description "action: creates a new --username account invited by --invited-by" + :short-name #\n + :long-name "new" + :key :new) + (clingon:make-option + :flag + :description "action: lists all accounts" + :short-name #\l + :long-name "list" + :key :list) + (clingon:make-option + :string + :description "action: sets password for --username" + :short-name #\p + :long-name "password" + :key :password) + (clingon:make-option + :string + :description "" + :short-name #\u + :long-name "username" + :key :username) + (clingon:make-option + :string + :description "" + :short-name #\i + :long-name "invited-by" + :key :inviter) + (clingon:make-option + :flag + :description "action: destroys account --username" + :short-name #\d + :long-name "delete" + :key :del?))) +@ %def account/command + +The [[account/manager]] is the main procedure of the {\tt account} +command. + +<>= +(defun account/manager (cmd) + (let ((args (clingon:command-arguments cmd)) + (new? (clingon:getopt cmd :new)) + (del? (clingon:getopt cmd :del?)) + (list? (clingon:getopt cmd :list)) + (pass (clingon:getopt cmd :password)) + (user (str:upcase (clingon:getopt cmd :username))) + (inviter (clingon:getopt cmd :inviter))) + (cond + (pass + (cond ((not user) + (return-from account/manager + (println "Option --username is required."))) + (t (account/change-passwd! user pass) + ;(println "Okay, ~a has now password ``~a''" user pass) + ))) + (del? + (cond ((not user) + (return-from account/manager + (println "Option --username is required."))) + ((not (get-account user)) + (return-from account/manager + (println "Account ~a not found." user))) + (t (remove-account! user) + (write-accounts!) + (println "Account ~a deleted." user)))) + (new? + (cond ((or (not user) (not inviter)) + (return-from account/manager + (println "Options --username, --invited-by are required."))) + ((not (user-name-conforms? user)) + (return-from account/manager + (println "Username ``~a'' doesn't conform to regex /<
>/." user))) + ((not (get-account inviter)) + (return-from account/manager + (println "Inviter ~a is not a known account; list'em all with ``account -l''." inviter))) + (t + (log-user-in-as! inviter) + (account/create-account! user (list inviter))))) + (list? (account/list-accounts)) + (t (println "Nothing to do. Say --help."))))) +@ %def account/manager + +You will find some redundancy here. For instance, we might be double +checking for human error. It's harmless, but we would like to address +that eventually. We end this section with the remaining account +management commands. + +<>= +(defun account/list-accounts () (println (str:join (crlf-string) (list-users)))) -(defun cli/create-account (username args) +(defun account/create-account! (username args) (let ((invited-by (car args))) (cond ((null invited-by) (println "Must specify who invites the new account.")) @@ -750,70 +939,18 @@ running a program [[./list-accounts]]. (notify-user-created username)) (println "Sorry, ~a." pass-or-error))))))) -(defun cli/change-passwd (username args) +(defun account/change-passwd! (username &optional given-passwd) (let* ((random-passwd (random-string 6)) - (given-passwd (car args)) (new-passwd (or given-passwd random-passwd))) (if (not (get-account username)) (println "No such account ``~a''." username) - (multiple-value-bind (okay? problem) (change-passwd! username new-passwd) (if okay? + (multiple-value-bind (okay? problem) (change-passwd! username new-passwd) + (if okay? (println "Okay, account ~a now has password ``~a''." username new-passwd) - (println "Sorry, could not change password: ~a." problem)))))) -@ %def cli/change-passwd cli/list-accounts cli/create-account + (println "Sorry, could not change password: ~a." problem)))))) +@ %def account/change-passwd! account/list-accounts account/create-account! -Now let's write the main procedure in command-line parsing. Notice -that because of the design of the [[clingon]] library, command-line -parsing becomes the main procedure of \lp. In other words, \lp's -service proper starts at [[server-start]]. - -<>= -(defun cli/main-with-handlers (cmd) - (handler-case - (cli/main cmd) - (end-of-file () - (print/finish "^D~%") - (uiop:quit 0)) - (interactive-interrupt () - (print/finish "^C~%") - (uiop:quit 0)))) - -(defun cli/main (cmd) - (read-accounts!) - (connect-index! "message-id.db") - (create-index!) - (let ((args (clingon:command-arguments cmd)) - (run-server t) - (repl (clingon:getopt cmd :repl)) - (ca (clingon:getopt cmd :create-account)) - (pa (clingon:getopt cmd :change-passwd)) - (la (clingon:getopt cmd :list-accounts)) - (logging (clingon:getopt cmd :logging)) - (disable-nntp-repl (clingon:getopt cmd :disable-nntp-repl))) - (setf *debug* logging) - (when (or ca pa la) - (setf run-server nil)) - (when la - (cli/list-accounts)) - (when ca - (cli/create-account ca args)) - (when pa - (cli/change-passwd pa args)) - (when repl - (repl (make-request :verb "repl" :args '(command-line)))) - (when disable-nntp-repl - (setq *enable-nntp-repl* nil)) - (when run-server - (server-start)))) - -(defun cli/command () - (clingon:make-command - :name "loop" - :description "<>" - :version "<>" - :license "GPL v3" - :options (cli/options) - :handler #'cli/main-with-handlers)) -@ %def cli/options cli/command +That's it for now. Good job. \section{Request dispatching mechanism} @@ -1140,26 +1277,29 @@ the problem? Two processes in parallel may ask for the writing of modifications lost. What do we need to do? Either we use file 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. +definitely a problem that we need to solve. XXX: Notice, too, that +there's a bug in [[write-accounts!]] that's hit when we try to write a +[[nil]] list of accounts. Of course, we should not let anyone delete +the root account, but we don't understand the bug. The bug is an +infinite loop of attempts. Why? We need to take the ignore-errors +from there to see what's happening. Not easy. <>= (defun write-accounts! () (let ((name - (loop - (let* ((tmp (random-string 10)) - (name (format nil "~a.tmp" tmp))) - (when - (ignore-errors - (with-open-file - (s name - :direction :output - :if-exists :error - :if-does-not-exist :create) - (write *accounts* :stream s))) - (return name)))))) - (if (ignore-errors (rename-file name "accounts.lisp")) - (values t *accounts*) - (values nil (format nil "could not rename ~a to accounts.lisp" name))))) + (let* ((tmp (random-string 10)) + (name (format nil "~a.tmp" tmp))) + (with-open-file + (s name + :direction :output + :if-exists :error + :if-does-not-exist :create) + (write *accounts* :stream s) + name)))) + (rename-file name "accounts.lisp") + (values t *accounts*) + ;(values nil (format nil "could not rename ~a to accounts.lisp" name)) + )) (defun get-account (username) (loop for u in *accounts* @@ -2119,7 +2259,7 @@ all or it has been discussed with the community beforehand. \subsection{{\tt REPL}} -\lp\ is totally {\em hackable}. Users can say {\tt repl} to have +\lp\ is totally {\em hackable}; users can say {\tt repl} to have complete control over their \lxxp\ process. <>= @@ -2218,7 +2358,7 @@ searching for the next line. \section{Article index}\label{sec:index} -Every NNTP server needs to have an index of articles. Each article is +An NNTP server needs to have an index of articles. Each article is indexed by its message-id. For example, the article % \begin{verbatim} @@ -2233,89 +2373,68 @@ indexed by its message-id. For example, the article Content-Transfer-Encoding: 8bit \end{verbatim} % -is indexed by the header {\tt message-id}. If you ask for article -{\tt <87plr25js5.fsf@tor.soy>}, \Lp\ will tell you that you can find -the article in group {\tt comp.unix} and its numeric ID is 37. Note -that the number 37 is not inside the article, but only in the name of -the file stored in the file system. The index, therefore, knows in -which file is each {\tt message-id}. This fact implies that you -cannot rename files in the file system---of course not: you'd changing -identifiers inside a database. If you have rename a file, you will -need to rebuild the index. Given that the index is an SQL table, you -can adjust the index relative to the any files you may need to rename -for whatever reason. You can also rebuild the entire index by reading -the file system---unless you have a lot of files, that's probably the -easiest thing to do. - -The use of [[*default-database*]] by the library [[clsql]] is very -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))) +is indexed by the header {\tt message-id} and the index will tell us +that you can find this article in {\tt + groups/comp.unix/<87plr25js5.fsf@tor.soy>}. We implement the index +as a symbolic link from {\tt index/<87plr25js5.fsf@tor.soy>} to {\tt + groups/comp.unix/<87plr25js5.fsf@tor.soy>}. Now, what happens when +an article belongs to multiple groups? The index will always point to +the first group. The other groups will have symbolic links to the +first group, too. This means we need to change [[post]] to reflect +the new way of storing articles. Let's create a procedure called +[[make-link]] that takes a message-id and a group name. The procedure +then creates a zero-byte file holding the id for the link and then +replaces it with a symbolic link. How will it replace it? It will +replace it by first writing the symbolic link to a temporary file and +then renaming it. In other words, we need a [[make-atomic-symlink]] +procedure. +<>= (defun create-index! () - (clsql:execute-command "create table if not exists indices - (id varchar(1000), grp varchar(1000), article varchar(300))") - (clsql:execute-command "create unique index if not exists idx_id_1 - on indices (id)")) + (ensure-directories-exist "index/")) + +(defun rm-rf (path) + (uiop:delete-directory-tree (pathname path) :validate t)) (defun drop-create-index! () - (clsql:execute-command "drop table if exists indices") + (rm-rf "index/") (create-index!)) -@ %def create-index! drop-create-index! connect-index! +@ %def create-index! drop-create-index! -Of course, the creation and connection of the index must occur before -[[main-loop]], so it takes place in [[main]]. +Hey, remember that [[rm-rf]] must be take a slashed directory. -When someone requests an article, it's either by its numeric index but -then the client has already chosen a group, or it's by its {\tt - message-id}. We don't need to tell the client to which groups the -article belongs; we just give the entire article to the client. It -is, therefore, the client's responsibility what to do with the -article. However, to fetch an article, we need to know where in the -database (in the file system) is the article; in other words, we must -know one group in which the article was stored. This implies that the -index must know at least one group. We've decided to always index the -first group in the {\tt newsgroups} header. So the index's anatomy is -$(m, g, i)$, where $m$ is the {\tt message-id}, $g$ is the name of the -group and $i$, is the name of the article in the file system. This -also defines the anatomy of the SQL table. +By the way, the creation and connection of the index must occur before +[[main-loop]], so it takes place in [[main]]. -Should we store more information in the index? Not really. If we -need anything about an article, we can get it after we fetch it from -the file system. For example, suppose that a search command wishes to -display the fact that article was posted in various groups. Suppose -further the command has already located in the index an article to be -displayed. This means the command has the {\tt message-id} and one of -the groups in which the article was posted. The command is then able -to fetch the entire article from the file system. Now it's a matter -of reading the article itself to know almost everything there is to -know about it. (It's also interesting that we keep the index thin -because we need to allow it to grow to great sizes.) +Writing a new article means creating the index and then writing the +file. So we need to make that into a transaction. Use +[[unwind-protect]] to delete the index entry if anything goes wrong +with writing the article. -%% (clsql:create-table "INDICES" '(([id] (string 1000)) ([grp] (string 1000)) ([article] (string 300)))) -%% (clsql:execute-command "create table if not exists indices (id varchar(1000), grp varchar(1000), article varchar(300))") +These and others are essential operations of the index. -%% LOOP> (clsql:create-index "idx_id_1" :on "indices" :attributes "id" :unique "id") -%% ; No value -%% (clsql:execute-command "CREATE UNIQUE INDEX if not exists idx_id_1 ON INDICES (ID)") +I think that in a time like this, literate programming doesn't help +much. I think we should go straight to the code right now and then +bring it back when it's done. Let's face it---we don't work linearly. +This is probably hindering us. Literate programming is to help us +organize, present, improve, understand; it's not here to help +prototype exactly. Let's write our ideas here, but the code straight +to the source code. Now I gotta be careful not to destroy work. If I +say {\tt make}, it will destroy? No, {\tt make} just compiles it as +it should. But if say {\tt nomake}, my work would be destroyed. Can +we stop that somehow? An easy solution is to destroy {\tt Nowebfile} +by moving it to {\tt Nowebfrost}. Elegant solution. But then we +cannot build the PDF either. But that's okay. -%% CL-USER> (clsql:list-attributes "indices") -%% ("ID" "GRP" "ARTICLE") - -%% CL-USER> (clsql:insert-records :into "indices" :attributes '(id grp article) :values '("<87plr25js5.fsf@tor.soy>" "comp.unix" 37)) -%% ; No value - -%% CL-USER> (clsql:select 'id 'grp 'article :from "indices") -%% (("<87plr25js5.fsf@tor.soy>" "comp.unix")) -%% ("ID" "GRP") +Now, the funny thing is that I only began directly at the source code +and soon I was back at literate programming. The changes were very +small in the end. So I said I was going to do one thing and did +another. But it's true that we don't write code linearly. Literate +programming is not the first place where we put the pen. We put the +pen on any piece of paper at all. When we realize we have something +with any resemblance of coherence, we then literate it out. That's +our approach here. Let's be very rational and use whatever works +best. Let's try to compile this thing. \section{Essential operations relative to the index} @@ -2332,32 +2451,33 @@ 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. +How do we insert a message to the index? We cannot atomically create +two files: the system won't do it for us. We'll need to build the +transaction ourselves and in Lisp that's easy with [[unwind-protect]]. + <>= (defun insert-index (m g i) - (handler-case - (clsql:insert-records - :into "indices" - :attributes '(id grp article) - :values (list (str:trim m) (str:trim g) (str:trim i))) - (clsql-sys:sql-database-data-error (c) - (cond ((= (slot-value c 'clsql-sys::error-id) 19) - 'already-indexed) - (t - ; We should log this error. - ;(format t "other error: ~a" (slot-value c 'clsql-sys::database-message)) - 'sql-error))) - (:no-error () - nil))) + (let ((from (fmt "index/~a" m)) + (to (fmt "../groups/~a/~a" g i))) + (create-symbolic-link from to))) +@ %def insert-index. +Lisp [[truename]] is not going to blow an error if message-id doesn't +exist on the file system. It's going to simply not translate the +path. What we do is take the last 2 elements of splitting the +pathname. If we get {\tt index}, it's because it wasn't translated. +This, of course, implies we cannot have a group named ``index''. What +we'll do instead is consider it a bug if the index would point to a +file that doesn't exist. It's really not supposed to happen. This +simplifies. + +<>= (defun lookup-index (mid) - (let* ((found (clsql:select [grp] [article] - :from [indices] - :where [= [id] (str:trim mid)])) - (article (first found)) - (grp (first article)) - (art (second article))) - (when found - (values grp art)))) + (let ((path (ignore-errors (truename (fmt "index/~a" mid))))) + (when path + (let* ((name (namestring path)) + (pair (last (str:split "/" name) 2))) + (values (car pair) (cadr pair)))))) @ %def insert-index lookup-index \section{Procedure to import the index from the file system} @@ -2396,13 +2516,16 @@ we need to index it. (index-from-fs!)) @ +Cool. We just rewrote the index, giving up on using sqlite, and we +don't need to update this procedure. Thanks to functional +abstraction. + 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") (drop-create-index!) (index-from-fs!) (format t "Index built.~%") @@ -2440,7 +2563,6 @@ that. (ql:quickload :loop :silent t) (in-package #:loop) (read-accounts!) -(connect-index! "message-id.db") (remove-inactive-users!) (write-accounts!) @ %def cron-remove-inactive-users.lisp @@ -2804,7 +2926,6 @@ A bad test from the biggest mouth of the south. (define-test post-okay (read-accounts!) - (connect-index! "test.db") (create-index!) (setq *client* (make-client :username "ROOT" :auth? 'yes)) (multiple-value-bind (code msg) (post (string->bytes a-post)) @@ -2817,7 +2938,7 @@ XXX: we got a problem with test [[post-okay]]. We're getting an execution error, but we can't see any error message. The posting is taking place---here in the REPL at least. -\section{How to produce the binary executable} +\section{Executable, how to build it} Just say {\tt make loop} to your shell. @@ -2838,7 +2959,7 @@ Just say {\tt make loop} to your shell. (load quicklisp-init))) @ %def quicklisp -\section{How to get a log of \lp's communication} +\section{Log of \lp's communication, how to produce it} If you invoke \lxxp\ with option [[--logging]], you get logging on [[stderr]]: @@ -2897,8 +3018,6 @@ something to think about. '(<>) :silent t)) -(clsql:file-enable-sql-reader-syntax) - (defpackage #:loop (:use :common-lisp :local-time) (:import-from :lisp-unit define-test assert-true) @@ -2916,7 +3035,7 @@ something to think about. <> <> <> -<> +<> <> <> <> @@ -2952,7 +3071,6 @@ something to think about. <> <> <> -<> <> <> <> diff --git a/make-release b/make-release old mode 100644 new mode 100755 diff --git a/scripts/build-index-from-fs.lisp b/scripts/build-index-from-fs.lisp index e6f9f68..737b096 100644 --- a/scripts/build-index-from-fs.lisp +++ b/scripts/build-index-from-fs.lisp @@ -5,7 +5,6 @@ (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 index 6d10913..9d10633 100644 --- a/scripts/cron-remove-inactive-users.lisp +++ b/scripts/cron-remove-inactive-users.lisp @@ -6,6 +6,5 @@ (ql:quickload :loop :silent t) (in-package #:loop) (read-accounts!) -(connect-index! "message-id.db") (remove-inactive-users!) (write-accounts!)