loop/srv
1
0
Fork 0
Code Issues Pull requests Activity

Writes index in the UNIX way.

Browse source 
Adds support for TAGS in noweb files.

I really don't know whether the above is complete or not.
This commit is contained in:
Circling Skies 2025-02-08 17:00:12 -03:00
parent 6db95ae6c4
commit 847c11ad95
9 changed files with 816 additions and 372 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Makefile
View file

@ -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`

40
Anyfile → Nowebfile
View file

@ -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

291
TAGS Normal file
View file

@ -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 :<<Name>>3108,119953

0
format-def Normal file → Executable file
View file

269
loop.lisp
View file

@ -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"))
(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)))))
;(values nil (format nil "could not rename ~a to accounts.lisp" name))
))
(defun get-account (username)
(loop for u in *accounts*
@ -1251,11 +1229,12 @@
maximizing (length (account-username u))))
(defun list-users ()
(read-accounts!)
(mapcar #'(lambda (row) (cadr row))
(mapcar
#'(lambda (row) (cadr row))
(sort
(loop for u in *accounts*
collect (list (account-username u)
collect (list
(account-username u)
(fmt "~v@a~a, ~a, invited ~a"
(size-of-longest-username)
(account-username u)
@ -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,63 +1460,16 @@
(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))
(defun main-loop ()
(loop
(let* ((bs (nntp-read-line))
@ -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))

520
loop.nw
View file

@ -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.
<<Command-line parsing>>=
(defun cli/options ()
(defun root/command ()
(clingon:make-command
:name "<<Name>>"
:description "<<Description>>"
:version "<<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 <VALUE>
-l, --list lists all accounts
-n, --new creates a new --username account invited by --invited-by
-p, --password <VALUE> sets password for --username
-u, --username <VALUE>
\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.
<<Command-line parsing>>=
(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.
<<Command-line parsing>>=
(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.
<<Command-line parsing>>=
(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 /<<Form of user names>>/." 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.
<<Command-line parsing>>=
(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
@ %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]].
<<Command-line parsing>>=
(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 "<<Description>>"
:version "<<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.
<<Command create-account>>=
(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"))
(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)))))
;(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.
<<Command repl>>=
@ -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.
<<Reference to the database>>=
(defparameter *default-database* nil)
@ %def *default-database*
<<How to create and connect to the index>>=
(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.
<<How to create the index>>=
(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
Hey, remember that [[rm-rf]] must be take a slashed directory.
By the way, the creation and connection of the index must occur before
[[main-loop]], so it takes place in [[main]].
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.
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.
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.)
These and others are essential operations of the index.
%% (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))")
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.
%% 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)")
%% 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]].
<<Essential operations relative to the index>>=
(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.
<<Essential operations relative to the index>>=
(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.
<<build-index-from-fs.lisp>>=
<<Quicklisp loading preamble>>
(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.
'(<<List of packages to be loaded>>)
: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.
<<Loop's REPL>>
<<Procedures for requests and responses>>
<<Essential operations relative to the index>>
<<How to create and connect to the index>>
<<How to create the index>>
<<How to remove inactive users>>
<<How to enumerate inactive accounts>>
<<How to migrate accounts without a creation date>>
@ -2952,7 +3071,6 @@ something to think about.
<<Representation of accounts>>
<<Representation of a client>>
<<Representation of requests and responses>>
<<Reference to the database>>
<<Representation of commands>>
<<Representation of articles>>
<<Definition of maximum allowed inactive periods>>

0
make-release Normal file → Executable file
View file

1
scripts/build-index-from-fs.lisp
View file

@ -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.~%")

1
scripts/cron-remove-inactive-users.lisp
View file

@ -6,6 +6,5 @@
(ql:quickload :loop :silent t)
(in-package #:loop)
(read-accounts!)
(connect-index! "message-id.db")
(remove-inactive-users!)
(write-accounts!)