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.
This commit is contained in:
parent
6db95ae6c4
commit
847c11ad95
9 changed files with 816 additions and 372 deletions
2
Makefile
2
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`
|
||||
|
|
|
|||
|
|
@ -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
291
TAGS
Normal 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
0
format-def
Normal file → Executable file
315
loop.lisp
315
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))
|
||||
|
|
|
|||
538
loop.nw
538
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.
|
||||
|
||||
<<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
|
||||
(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]].
|
||||
|
||||
<<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"))
|
||||
(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.
|
||||
|
||||
<<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
|
||||
[[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]].
|
||||
|
||||
<<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
0
make-release
Normal file → Executable 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.~%")
|
||||
|
|
|
|||
|
|
@ -6,6 +6,5 @@
|
|||
(ql:quickload :loop :silent t)
|
||||
(in-package #:loop)
|
||||
(read-accounts!)
|
||||
(connect-index! "message-id.db")
|
||||
(remove-inactive-users!)
|
||||
(write-accounts!)
|
||||
|
|
|
|||
Loading…
Reference in a new issue