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

Implements LIST {NEWSGROUPS,SUBSCRIPTIONS}

Browse source
This commit is contained in:
Circling Skies 2025-09-19 20:15:28 -03:00
parent 847c11ad95
commit 179c6fea59
6 changed files with 659 additions and 618 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

545
TAGS
View file

@ -15,277 +15,276 @@ loop.nw,3549
Section \ref{sec:inactive-users}sec:inactive-users148,6361 Section \ref{sec:inactive-users}sec:inactive-users148,6361
\section*{*184,8177 \section*{*184,8177
\section{Implementation strategy}\label{sec:design}Implementation190,8309 \section{Implementation strategy}\label{sec:design}Implementation190,8309
illustrated in Figures~\ref{fg:gnus}fg:gnus319,12489 illustrated in Figures~\ref{fg:gnus}fg:gnus319,12490
Section~\ref{sec:repl}sec:repl323,12758 Section~\ref{sec:repl}sec:repl323,12759
\section{NNTP protocol}NNTP328,12991 \section{NNTP protocol}NNTP328,12992
\section{It's a network server}It's342,13733 \section{It's a network server}It's342,13734
through the command line as illustrated in Section~\ref{sec:design}sec:design369,15205 through the command line as illustrated in Section~\ref{sec:design}sec:design369,15206
\section{REPL for \lp}\label{sec:repl}REPL371,15275 \section{REPL for \lp}\label{sec:repl}REPL371,15276
\section{Representation of a client}Representation437,17373 \section{Representation of a client}Representation437,17374
\section{Representation of a command}Representation449,17769 \section{Representation of a command}Representation449,17770
\section{Representation of requests and responses}Representation517,20742 \section{Representation of requests and responses}Representation517,20737
\section{Main loop}Main594,23952 \section{Main loop}Main594,23947
\section{Parsing of requests}Parsing668,25894 \section{Parsing of requests}Parsing669,25880
\section{Parsing of command-line arguments}Parsing687,26655 \section{Parsing of command-line arguments}Parsing688,26641
\section{Request dispatching mechanism}Request956,36835 \section{Request dispatching mechanism}Request961,36913
\section{Representation and parsing of articles}Representation977,37628 \section{Representation and parsing of articles}Representation982,37706
\section{How to extract articles from the database}How1056,40692 \section{How to extract articles from the database}How1065,40809
\section{Commands}Commands1106,42494 \section{Commands}Commands1115,42605
\subsection{{\tt HELP}}1108,42514 \subsection{{\tt HELP}}1117,42625
\subsection{{\tt AUTHINFO}}\label{sec:authinfo}1142,43799 \subsection{{\tt AUTHINFO}}\label{sec:authinfo}1151,43910
Section~\ref{sec:login}sec:login1148,44091 Section~\ref{sec:login}sec:login1157,44202
\subsection{{\tt CREATE-ACCOUNT}}1193,45783 \subsection{{\tt CREATE-ACCOUNT}}1202,45894
\subsection{{\tt UNLOCK-ACCOUNT}}1311,50341 \subsection{{\tt UNLOCK-ACCOUNT}}1320,50452
\ref{sec:inactive-users}sec:inactive-users1314,50430 \ref{sec:inactive-users}sec:inactive-users1323,50541
\subsection{{\tt LOGIN}}\label{sec:login}1347,51741 \subsection{{\tt LOGIN}}\label{sec:login}1356,51852
Besides {\tt AUTHINFO} in Section~\ref{sec:authinfo}sec:authinfo1349,51784 Besides {\tt AUTHINFO} in Section~\ref{sec:authinfo}sec:authinfo1358,51895
\subsection{{\tt PASSWD}}\label{sec:passwd}1375,52745 \subsection{{\tt PASSWD}}\label{sec:passwd}1384,52856
\subsection{{\tt USERS}}\label{sec:users}1421,54619 \subsection{{\tt USERS}}\label{sec:users}1430,54730
\subsection{{\tt LIST}}\label{sec:list}1471,56270 \subsection{{\tt LIST}}\label{sec:list}1480,56381
\subsection{{\tt GROUP}}\label{sec:group}1623,62335 \subsection{{\tt GROUP}}\label{sec:group}1632,62446
\subsection{{\tt BODY}, {\tt HEAD}, {\tt ARTICLE} e {\tt NEXT}}1653,63159 \subsection{{\tt BODY}, {\tt HEAD}, {\tt ARTICLE} e {\tt NEXT}}1662,63270
\label{sec:typical-cmds}sec:typical-cmds1654,63223 \label{sec:typical-cmds}sec:typical-cmds1663,63334
Section~\ref{sec:index}sec:index1664,63791 Section~\ref{sec:index}sec:index1673,63902
\subsection{{\tt XOVER}}\label{sec:xover}1766,68395 \subsection{{\tt XOVER}}\label{sec:xover}1775,68503
\subsection{{\tt MODE READER}}\label{sec:mode-reader}1824,70966 \subsection{{\tt MODE READER}}\label{sec:mode-reader}1833,71074
\subsection{{\tt DATE}}\label{sec:date}1833,71213 \subsection{{\tt DATE}}\label{sec:date}1842,71321
\subsection{{\tt QUIT}}\label{sec:quit}1846,71556 \subsection{{\tt QUIT}}\label{sec:quit}1855,71664
\subsection{{\tt DD}}\label{sec:dd}1856,71819 \subsection{{\tt DD}}\label{sec:dd}1865,71927
\subsection{{\tt POST}}\label{sec:post}1868,72221 \subsection{{\tt POST}}\label{sec:post}1878,72420
\subsection{{\tt CREATE-GROUP}}2224,87356 \subsection{{\tt CREATE-GROUP}}2241,87684
\subsection{{\tt REPL}}2261,89096 \subsection{{\tt REPL}}2278,89424
\section{Publication of news}Publication2288,89946 \section{Publication of news}Publication2305,90274
\section{Algorithm of {\tt split-vector}}Algorithm2329,91508 \section{Algorithm of {\tt split-vector}}Algorithm2346,91833
\section{Article index}\label{sec:index}Article2360,92703 \section{Article index}\label{sec:index}Article2377,93028
\section{Essential operations relative to the index}Essential2455,97073 \section{Essential operations relative to the index}Essential2457,96627
\section{Procedure to import the index from the file system}Procedure2498,98728 \section{Procedure to import the index from the file system}Procedure2502,98639
\section{Deletion and locking of inactive accounts}\label{sec:inactive-users}Deletion2561,100684 \section{Deletion and locking of inactive accounts}\label{sec:inactive-users}Deletion2568,100703
\section{Macros to ease writing}\label{sec:dsl}Macros2728,107298 \section{Macros to ease writing}\label{sec:dsl}Macros2734,107284
\section{Other procedures}Other2791,109436 \section{Other procedures}Other2797,109416
\section{Tests}Tests2881,112192 \section{Tests}Tests2887,112172
\section{Executable, how to build it}Executable,2955,115097 \section{Executable, how to build it}Executable,2960,115048
\section{Log of \lp's communication, how to produce it}Log2976,115677 \section{Log of \lp's communication, how to produce it}Log2981,115628
\section{Package {\tt loop.lisp} as the compiler needs it}Package3013,117026 \section{Package {\tt loop.lisp} as the compiler needs it}Package3018,116977
\section{Other source code}Other3115,120122 \section{Other source code}Other3118,120026
\section*{*3195,122671 \section*{*3209,123229
\section*{*3198,122712 \section*{*3212,123270
loop.nw,7305 loop.nw,7251
(defun repl 406,16343 (defun repl 406,16344
(defstruct client 444,17634 (defstruct client 444,17635
(defparameter *client* 445,17706 (defparameter *client* 445,17707
(defstruct command 460,18265 (defstruct command 460,18266
(defparameter *commands-assoc* 461,18305 (defparameter *commands-assoc* 461,18306
(defun table-of-commands 465,18368 (defun table-of-commands 465,18369
(defun set-up-tables! 490,19685 (defun set-up-tables! 490,19679
(defun get-command 503,20181 (defun get-command 503,20175
(defstruct request 532,21442 (defstruct request 532,21437
(defstruct response 533,21477 (defstruct response 533,21472
(defun empty-response 537,21574 (defun empty-response 537,21569
(defun prepend-response-with 538,21653 (defun prepend-response-with 538,21648
(defun append-crlf-if-needed 549,22043 (defun append-crlf-if-needed 549,22038
(defun send-response! 559,22363 (defun send-response! 559,22358
(defun my-write 588,23775 (defun my-write 588,23770
(defun main-loop 609,24653 (defun main-loop 609,24648
(defun request-quit? 617,24876 (defun request-quit? 617,24871
(defun response-quit? 618,24943 (defun response-quit? 618,24938
(defun server-start 620,25016 (defun server-start 620,25011
(defun main 625,25091 (defun main 625,25086
(defun send-banner! 632,25233 (defun send-banner! 633,25219
(defun parse-request 675,26144 (defun parse-request 676,26130
(defun root/command 716,28117 (defun root/command 717,28103
(defun root/options 725,28344 (defun root/options 726,28330
(defun root/handlers 744,28795 (defun root/handlers 745,28781
(defun root/main 809,31474 (defun root/main 812,31505
(defun account/command 824,31972 (defun account/command 829,32050
(defun account/options 831,32139 (defun account/options 836,32217
(defun account/manager 875,33168 (defun account/manager 880,33246
(defun account/list-accounts 924,35337 (defun account/list-accounts 929,35415
(defun account/create-account! 927,35421 (defun account/create-account! 932,35499
(defun account/change-passwd! 943,36207 (defun account/change-passwd! 948,36285
(defun dispatch 967,37362 (defun dispatch 972,37440
(defun dispatch-line 973,37517 (defun dispatch-line 978,37595
(defstruct article 998,38720 (defstruct article 1001,38661
(defun parse-article 1002,38784 (defun parse-article 1005,38761
(defun hs-space-collapsed 1006,38965 (defun hs-space-collapsed 1017,39117
(defun hs-lines 1009,39081 (defun hs-lines 1020,39233
(defun parse-header 1011,39139 (defun parse-header 1022,39291
(defun parse-headers 1024,39630 (defun parse-head 1033,39765
(defun string-integer? 1028,39756 (defun string-integer? 1037,39888
(defun get-header-from-article 1035,39991 (defun get-header-from-article 1044,40120
(defun get-header 1038,40099 (defun get-header 1047,40222
(defun fetch-headers 1042,40205 (defun fetch-headers 1051,40328
(defun enrich-headers 1048,40421 (defun enrich-headers 1057,40538
(defun nlines 1053,40603 (defun nlines 1062,40720
(defun fetch-article 1064,41049 (defun fetch-article 1073,41166
(defun read-file-raw 1068,41136 (defun read-file-raw 1077,41253
(defun fetch-body 1079,41431 (defun fetch-body 1088,41548
(defun encode-body 1090,41887 (defun encode-body 1099,42004
(defun extract-mid 1100,42298 (defun extract-mid 1109,42415
(defun lookup 1102,42398 (defun lookup 1111,42509
(defun cmd-help 1123,43298 (defun cmd-help 1132,43409
(defun menu 1131,43561 (defun menu 1140,43672
(defun display-fn 1135,43639 (defun display-fn 1144,43750
(defun cmd-authinfo 1158,44464 (defun cmd-authinfo 1167,44575
(defun authinfo-check 1180,45447 (defun authinfo-check 1189,45558
(defun auth? 1183,45516 (defun auth? 1192,45627
(defun log-user-in! 1186,45570 (defun log-user-in! 1195,45681
(defun user-name-conforms? 1213,46445 (defun user-name-conforms? 1222,46556
(defun cmd-create-account 1217,46550 (defun cmd-create-account 1226,46661
(defstruct account 1234,47320 (defstruct account 1243,47431
(defparameter *accounts* 1235,47414 (defparameter *accounts* 1244,47525
(defun read-accounts! 1239,47491 (defun read-accounts! 1248,47602
(defun string->array 1247,47688 (defun string->array 1256,47799
(defun string->sha256 1252,47849 (defun string->sha256 1261,47960
(defun new-account! 1256,47997 (defun new-account! 1265,48108
(defun write-accounts! 1289,49613 (defun write-accounts! 1298,49724
(defun get-account 1305,50135 (defun get-account 1314,50246
(defun cmd-unlock-account 1318,50539 (defun cmd-unlock-account 1327,50650
(defun unlock-account! 1335,51329 (defun unlock-account! 1344,51440
(defun cmd-login 1355,52064 (defun cmd-login 1364,52175
(defun log-user-in-as! 1370,52632 (defun log-user-in-as! 1379,52743
(defun cmd-passwd 1382,53017 (defun cmd-passwd 1391,53128
(defun pass? 1401,53919 (defun pass? 1410,54030
(defun change-passwd! 1412,54342 (defun change-passwd! 1421,54453
(defun cmd-list-users 1427,54763 (defun cmd-list-users 1436,54874
(defun size-of-longest-username 1435,54990 (defun size-of-longest-username 1444,55101
(defun list-users 1439,55105 (defun list-users 1448,55216
(defun universal-to-human 1459,55939 (defun universal-to-human 1468,56050
(defun last-time-seen 1465,56058 (defun last-time-seen 1474,56169
(defstruct group 1481,56720 (defstruct group 1490,56831
(defun cmd-list 1483,56753 (defun cmd-list 1492,56864
(defun build-groups-lines 1490,57013 (defun build-groups-lines 1499,57124
(defun build-groups-structs 1497,57177 (defun build-groups-structs 1506,57288
(defun between? 1504,57442 (defun between? 1513,57553
(defun filesize 1508,57517 (defun filesize 1517,57628
(defun zero-file? 1512,57589 (defun zero-file? 1521,57700
(defun temporary-article? 1515,57640 (defun temporary-article? 1524,57751
(defun article-ready? 1519,57749 (defun article-ready? 1528,57860
(defun get-articles 1524,57866 (defun get-articles 1533,57977
(defun group-high-low 1534,58254 (defun group-high-low 1543,58365
(defun articles->integers 1541,58481 (defun articles->integers 1550,58592
(defun list-groups 1548,58718 (defun list-groups 1557,58829
(defun last-char 1553,58915 (defun last-char 1562,59026
(defun basename 1561,59128 (defun basename 1570,59239
(defun loop-directory* 1582,60148 (defun loop-directory* 1591,60259
(defun loop-list-files 1592,60810 (defun loop-list-files 1601,60921
(defun loop-list-directories 1601,61165 (defun loop-list-directories 1610,61276
(defun cmd-group 1628,62466 (defun cmd-group 1637,62577
(defun group? 1639,62876 (defun group? 1648,62987
(defun xgroup? 1643,62946 (defun xgroup? 1652,63057
(defun set-group! 1646,62986 (defun set-group! 1655,63097
(defun typical-cmd-head-body-article 1667,63887 (defun typical-cmd-head-body-article 1676,63998
(defun cmd-head 1683,64754 (defun cmd-head 1692,64865
(defun cmd-body 1685,64827 (defun cmd-body 1694,64938
(defun cmd-article 1687,64900 (defun cmd-article 1696,65011
(defun article-response 1690,64980 (defun article-response 1699,65091
(defun head-response 1692,65079 (defun head-response 1701,65190
(defun body-response 1694,65195 (defun body-response 1703,65303
(defun typical-cmd-response 1723,66781 (defun typical-cmd-response 1732,66889
(defun cmd-next 1744,67563 (defun cmd-next 1753,67671
(defun article-next! 1755,68017 (defun article-next! 1764,68125
(defun mid-by-name 1762,68284 (defun mid-by-name 1771,68392
(defun cmd-xover 1775,68756 (defun cmd-xover 1784,68864
(defun xover 1794,69713 (defun xover 1803,69821
(defun xover-format-line 1815,70635 (defun xover-format-line 1824,70743
(defun xover-headers 1820,70857 (defun xover-headers 1829,70965
(defun cmd-mode 1829,71112 (defun cmd-mode 1838,71220
(defun cmd-date 1839,71400 (defun cmd-date 1848,71508
(defun cmd-quit 1852,71733 (defun cmd-quit 1861,71841
(defun cmd-dd 1864,72114 (defun cmd-test 1873,72224
(defun suggest-message-id 1880,72765 (defun suggest-message-id 1890,72964
(defun random-string 1883,72857 (defun random-string 1893,73056
(defun unparse-article 1897,73270 (defun unparse-article 1907,73469
(defun ensure-header 1914,73886 (defun ensure-header 1924,74079
(defun get-date 1927,74369 (defun get-date 1937,74556
(defun ensure-mid 1934,74611 (defun ensure-mid 1944,74798
(defun ensure-date 1936,74690 (defun ensure-date 1946,74877
(defun cmd-post 1964,75771 (defun cmd-post 1974,75958
(defun post 1998,77338 (defun post 2009,77527
(defun newsgroups-header->list 2020,78438 (defun newsgroups-header->list 2033,78605
(defun update-last-post-date! 2035,79134 (defun update-last-post-date! 2048,79301
(defun rename-no-extension 2053,80063 (defun rename-no-extension 2066,80230
(defun save-article-try 2056,80166 (defun save-article-try 2069,80333
(defun save-article-insist 2084,81134 (defun save-article-insist 2103,81607
(defun get-next-article-id 2090,81408 (defun get-next-article-id 2109,81828
(defun nntp-read-article 2106,82107 (defun nntp-read-article 2125,82527
(defun nntp-read-line 2125,82983 (defun nntp-read-line 2144,83403
(defun list->bytes 2134,83346 (defun list->bytes 2153,83766
(defun vector->bytes 2137,83400 (defun vector->bytes 2156,83820
(defun data->bytes 2140,83469 (defun data->bytes 2159,83889
(defun add-crlf-between 2148,83738 (defun add-crlf-between 2167,84158
(defun string->bytes 2152,83890 (defun string->bytes 2171,84310
(defun bytes->string 2155,83945 (defun bytes->string 2174,84365
(defun conforms? 2177,84969 (defun conforms? 2194,85304
(defun text/plain? 2190,85624 (defun text/plain? 2207,85952
(defun headers-required-from-clients 2199,85967 (defun headers-required-from-clients 2216,86295
(defun cmd-create-group 2234,87805 (defun cmd-create-group 2251,88133
(defun group-name-conforms? 2257,88972 (defun group-name-conforms? 2274,89300
(defun cmd-repl 2267,89249 (defun cmd-repl 2284,89577
(defparameter *enable-nntp-repl* 2285,89906 (defparameter *enable-nntp-repl* 2302,90234
(defun notify-group-created 2295,90179 (defun notify-group-created 2312,90507
(defun notify-user-created 2300,90390 (defun notify-user-created 2317,90718
(defun notify-user-unlocked 2305,90588 (defun notify-user-unlocked 2322,90916
(defun post-notification 2311,90805 (defun post-notification 2328,91133
(defun make-news 2317,91098 (defun make-news 2334,91423
(defun split-vector 2340,92004 (defun split-vector 2357,92329
(defun split-vector-helper 2344,92146 (defun split-vector-helper 2361,92471
(defparameter *default-database* 2391,93939 (defun create-index! 2411,94531
(defun connect-index! 2395,94048 (defun rm-rf 2414,94595
(defun create-index! 2398,94167 (defun drop-create-index! 2417,94676
(defun drop-create-index! 2404,94414 (defun insert-index 2477,97606
(defun insert-index 2471,97843 (defun lookup-index 2494,98361
(defun lookup-index 2487,98372 (defun index-from-fs! 2524,99476
(defun index-from-fs! 2520,99565 (defun remake-index-from-fs 2533,99889
(defun remake-index-from-fs 2529,99978 (defun remove-inactive-users! 2592,101636
(defun remove-inactive-users! 2586,101650 (defun remove-account! 2628,103539
(defun remove-account! 2622,103553 (defun lock-account! 2636,103831
(defun lock-account! 2630,103845 (defun loop-epoch 2652,104565
(defun loop-epoch 2646,104579 (defun migrate-add-creation-and-post-date! 2655,104626
(defun migrate-add-creation-and-post-date! 2649,104640 (defparameter *months-inactive-allowed* 2677,105392
(defparameter *months-inactive-allowed* 2671,105406 (defparameter *months-never-logged-in* 2678,105435
(defparameter *months-never-logged-in* 2672,105449 (defun user-inactive? 2682,105521
(defun user-inactive? 2676,105535 (defun inactive-from-never-logged-in? 2686,105647
(defun inactive-from-never-logged-in? 2680,105661 (defun locked? 2693,105901
(defun locked? 2687,105915 (defun inactive-from-last-post? 2696,105988
(defun inactive-from-last-post? 2690,106002 (defun inactive-from-last-seen? 2704,106346
(defun inactive-from-last-seen? 2698,106360 (defun inactive-from? 2713,106695
(defun inactive-from? 2707,106709 (defun ever-logged-in? 2721,106902
(defun ever-logged-in? 2715,106916 (defun never-logged-in? 2724,106978
(defun never-logged-in? 2718,106992 (defun list-inactive-users 2727,107050
(defun list-inactive-users 2721,107064 (defmacro in-dir 2742,107560
(defmacro in-dir 2736,107574 (defmacro in-groups 2756,108079
(defmacro in-groups 2750,108093 (defun in-group-lambda 2758,108141
(defun in-group-lambda 2752,108155 (defmacro in-group 2760,108197
(defmacro in-group 2754,108211 (defmacro with-group 2763,108297
(defmacro with-group 2757,108311 (defmacro with-n-args 2773,108619
(defmacro with-n-args 2767,108639 (defmacro with-group-set 2783,108996
(defmacro with-group-set 2777,109016 (defmacro with-auth 2790,109201
(defmacro with-auth 2784,109221 (defun conforms-to? 2808,109948
(defun conforms-to? 2802,109968 (defun print/finish 2815,110199
(defun print/finish 2809,110219 (defun word-plural 2819,110285
(defun word-plural 2813,110305 (defun plural 2826,110536
(defun plural 2820,110556 (defun out 2833,110720
(defun out 2827,110740 (defun stderr 2836,110791
(defun stderr 2830,110811 (defun stdout 2841,110917
(defun stdout 2835,110937 (defun println 2844,110993
(defun println 2838,111013 (defun enumerate 2847,111105
(defun enumerate 2841,111125 (defun ucs-2->ascii 2851,111222
(defun ucs-2->ascii 2845,111242 (defun bad-input 2855,111319
(defun bad-input 2849,111339 (defun integer->string 2858,111416
(defun integer->string 2852,111436 (defun mkstr 2861,111467
(defun mkstr 2855,111487 (defun data 2865,111572
(defun data 2859,111592 (defun crlf 2868,111655
(defun crlf 2862,111675 (defun crlf-string 2871,111689
(defun crlf-string 2865,111709 (defun flatten 2874,111755
(defun flatten 2868,111775 (defmacro mac 2883,112041
(defmacro mac 2877,112061 (define-test dispatching2918,113875
(define-test dispatching2912,113895 (defun unix->nntp 2921,113970
(defun unix->nntp 2915,113990 (defvar a-post 2925,114082
(defvar a-post 2919,114102 (defvar a-bad-post 2933,114231
(defvar a-bad-post 2927,114251 (define-test post-wrong-newsgroup2941,114426
(define-test post-wrong-newsgroup2935,114446 (define-test post-okay2946,114593
(define-test post-okay2940,114613 (defpackage #:loop3040,118020
(defpackage #:loop3037,118108 (defparameter *debug* 3090,119274
(defparameter *debug* 3086,119338 (asdf:defsystem :<<Name>>3111,119857
(asdf:defsystem :<<Name>>3108,119953

14
groups/local.control.news/1
View file

@ -1,7 +1,7 @@
Date: 2024-03-07 21:44:31 GMT-3 Date: 2024-03-07 21:44:31 GMT-3
Message-Id: <edjocyeqzqqhnswlbrbo@loop> Message-Id: <edjocyeqzqqhnswlbrbo@loop>
From: Loop From: Loop
Subject: let there be light Subject: let there be light
Newsgroups: local.control.news Newsgroups: local.control.news
Administrative news will be posted here by me. -- Loop Administrative news will be posted here by me. -- Loop

2
loop.asd
View file

@ -1,6 +1,6 @@
;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*- ;;; -*- Mode: LISP; Syntax: COMMON-LISP; -*-
(asdf:defsystem :LOOP (asdf:defsystem :LOOP
:version "a89e088" :version "ec13a0c"
:description "An NNTP server for a circle of friends." :description "An NNTP server for a circle of friends."
:depends-on (:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon :depends-on (:lisp-unit :str :uiop :cl-ppcre :local-time :clsql-sqlite3 :clingon
:filesystem-utils :ironclad/digest/sha256) :filesystem-utils :ironclad/digest/sha256)

301
loop.lisp
View file

@ -9,7 +9,8 @@
(:use :common-lisp :local-time) (:use :common-lisp :local-time)
(:import-from :lisp-unit define-test assert-true) (:import-from :lisp-unit define-test assert-true)
(:import-from :org.shirakumo.filesystem-utils (:import-from :org.shirakumo.filesystem-utils
directory-p list-directories list-files) directory-p list-directories list-files
create-symbolic-link)
(:import-from :sb-sys interactive-interrupt) (:import-from :sb-sys interactive-interrupt)
(:export :main)) (:export :main))
@ -24,7 +25,7 @@
(defstruct response code data request multi-line) (defstruct response code data request multi-line)
(defstruct command fn verb description) (defstruct command fn verb description)
(defparameter *commands-assoc* nil) (defparameter *commands-assoc* nil)
(defstruct article headers body) (defstruct article message-id newsgroups headers username body head)
(defparameter *months-inactive-allowed* 3) (defparameter *months-inactive-allowed* 3)
(defparameter *months-never-logged-in* 1) (defparameter *months-never-logged-in* 1)
(defparameter *enable-nntp-repl* t) (defparameter *enable-nntp-repl* t)
@ -48,7 +49,7 @@
"creates an account so you can invite a friend") "creates an account so you can invite a friend")
("PASSWD" ,#'cmd-passwd "changes your password") ("PASSWD" ,#'cmd-passwd "changes your password")
("USERS" ,#'cmd-list-users "lists all users") ("USERS" ,#'cmd-list-users "lists all users")
("DD" ,#'cmd-dd "[d]isplays [d]ata: your state of affairs") ("TEST" ,#'cmd-test "runs a developer's experiment")
("QUIT" ,#'cmd-quit "politely says good-bye") ("QUIT" ,#'cmd-quit "politely says good-bye")
("DATE" ,#'cmd-date "displays the current date at this server") ("DATE" ,#'cmd-date "displays the current date at this server")
("UNLOCK-ACCOUNT" ,#'cmd-unlock-account "unlocks an account") ("UNLOCK-ACCOUNT" ,#'cmd-unlock-account "unlocks an account")
@ -74,7 +75,7 @@
:fn #'(lambda (r) :fn #'(lambda (r)
(make-response (make-response
:code 400 :code 400
:data "unrecognized command" :data "Unrecognized command."
:request r)) :request r))
:verb 'unrecognized :verb 'unrecognized
:description "a command for all commands typed wrong"))) :description "a command for all commands typed wrong")))
@ -99,7 +100,7 @@
(,r-var ,r)) (,r-var ,r))
(if (not (group? ,g-var)) (if (not (group? ,g-var))
(make-response :code 411 :request ,r-var (make-response :code 411 :request ,r-var
:data (format nil "no such group ``~a''" ,g-var)) :data (fmt "No such group ``~a''." ,g-var))
(progn ,@body))))) (progn ,@body)))))
(defmacro with-n-args (n r &rest body) (defmacro with-n-args (n r &rest body)
@ -175,20 +176,20 @@
(make-response :code (or code 400) :data msg :request r)) (make-response :code (or code 400) :data msg :request r))
(defun integer->string (n) (defun integer->string (n)
(format nil "~a" n)) (fmt "~a" n))
(defun mkstr (&rest args) ;; a utility (defun mkstr (&rest args)
(with-output-to-string (s) (with-output-to-string (s)
(dolist (a args) (princ a s)))) (dolist (a args) (princ a s))))
(defun data (&rest args) ;; a utility (defun data (&rest args)
(flatten (map 'list #'data->bytes args))) (flatten (map 'list #'data->bytes args)))
(defun crlf () (defun crlf ()
(vector 13 10)) (vector 13 10))
(defun crlf-string () (defun crlf-string ()
(format nil "~c~c" #\return #\linefeed)) (fmt "~c~c" #\return #\linefeed))
(defun flatten (obj) (defun flatten (obj)
(do* ((result (list obj)) (do* ((result (list obj))
@ -249,7 +250,7 @@
(append seq (append seq
(when (not (= (car (last seq)) 10)) (when (not (= (car (last seq)) 10))
(list 13 10)))) (list 13 10))))
(t (error (format nil "append-crlf-if-needed: unsupported type: ~a" (type-of seq)))))) (t (error (fmt "append-crlf-if-needed: unsupported type: ~a" (type-of seq))))))
(defun send-response! (r) (defun send-response! (r)
(let ((bs (data (integer->string (response-code r)) " " (let ((bs (data (integer->string (response-code r)) " "
@ -282,6 +283,7 @@
(defun insert-index (m g i) (defun insert-index (m g i)
(let ((from (fmt "index/~a" m)) (let ((from (fmt "index/~a" m))
(to (fmt "../groups/~a/~a" g i))) (to (fmt "../groups/~a/~a" g i)))
(stderr "Creating link from ~a to ~a...~%" from to)
(create-symbolic-link from to))) (create-symbolic-link from to)))
(defun lookup-index (mid) (defun lookup-index (mid)
@ -433,12 +435,24 @@
(drop-create-index!) (drop-create-index!)
(index-from-fs!)) (index-from-fs!))
(defun parse-article (v) (defun parse-article (v &optional (username nil))
(let ((parts (split-vector (vector 13 10 13 10) v nil :limit 2))) (let* ((parts (split-vector (vector 13 10 13 10) v nil :limit 2))
(make-article :headers (map 'string #'code-char (car parts)) :body (cadr parts)))) (head (car parts))
(head-str (map 'string #'code-char head))
(headers (parse-head head-str))
(body (cadr parts))
(mid (lookup "message-id" headers))
(ngs (str:split "," (str:collapse-whitespaces (lookup "newsgroups" headers)))))
(make-article
:headers headers
:message-id mid
:newsgroups ngs
:username username
:head head-str
:body body)))
(defun hs-space-collapsed (hs) (defun hs-space-collapsed (hs)
(cl-ppcre:regex-replace-all (format nil "~a[ ~a]+" (crlf-string) #\tab) hs " ")) (cl-ppcre:regex-replace-all (fmt "~a[ ~a]+" (crlf-string) #\tab) hs " "))
(defun hs-lines (lines) (str:split (crlf-string) lines)) (defun hs-lines (lines) (str:split (crlf-string) lines))
@ -446,23 +460,21 @@
(let* ((h (str:collapse-whitespaces header)) (let* ((h (str:collapse-whitespaces header))
(pos (search ":" h))) (pos (search ":" h)))
(when (null pos) (when (null pos)
(throw 'article-syntax-error (throw 'article-syntax-error (values nil (fmt "missing colon in header |~a|" h))))
(values nil (format nil "missing colon in header |~a|" h))))
(when (<= (length h) (+ 2 pos)) (when (<= (length h) (+ 2 pos))
(throw 'article-syntax-error (throw 'article-syntax-error (values nil (fmt "empty header ~a" h))))
(values nil (format nil "empty header ~a" h))))
(multiple-value-bind (key val) (multiple-value-bind (key val)
(values (subseq h 0 pos) (subseq h (+ 2 pos))) (values (subseq h 0 pos) (subseq h (+ 2 pos)))
(cons (str:downcase key) val)))) (cons (str:downcase key) val))))
(defun parse-headers (hs) (defun parse-head (hs)
(let ((ls (hs-lines (hs-space-collapsed hs)))) (let ((ls (hs-lines (hs-space-collapsed hs))))
(mapcar #'(lambda (h) (parse-header h)) ls))) (mapcar #'(lambda (h) (parse-header h)) ls)))
(defun string-integer? (s) (ignore-errors (parse-integer s))) (defun string-integer? (s) (ignore-errors (parse-integer s)))
(defun get-header-from-article (h a) (defun get-header-from-article (h a)
(get-header h (parse-headers (article-headers (parse-article a))))) (get-header h (parse-head (article-head (parse-article a)))))
(defun get-header (key hs) (defun get-header (key hs)
(let ((pair (assoc key hs :test #'string=))) (let ((pair (assoc key hs :test #'string=)))
@ -471,19 +483,19 @@
(defun fetch-headers (g i) (defun fetch-headers (g i)
(let* ((a-string (fetch-article g i)) (let* ((a-string (fetch-article g i))
(a-parsed (parse-article a-string)) (a-parsed (parse-article a-string))
(headers (parse-headers (article-headers a-parsed)))) (headers (parse-head (article-head a-parsed))))
(enrich-headers headers a-string))) (enrich-headers headers a-string)))
(defun enrich-headers (hs a) (defun enrich-headers (hs a)
(append hs (append hs
`(("line-count" . ,(format nil "~a" (nlines (article-body (parse-article a))))) `(("line-count" . ,(fmt "~a" (nlines (article-body (parse-article a)))))
("byte-count" . ,(format nil "~a" (length a)))))) ("byte-count" . ,(fmt "~a" (length a))))))
(defun nlines (v) (length (split-vector (crlf) v nil))) (defun nlines (v) (length (split-vector (crlf) v nil)))
(defun fetch-article (g i) (defun fetch-article (g i)
(in-groups (in-groups
(read-file-raw (format nil "~a/~a" g i)))) (read-file-raw (fmt "~a/~a" g i))))
(defun read-file-raw (path) (defun read-file-raw (path)
(with-open-file (with-open-file
@ -502,7 +514,7 @@
(defun encode-body (a) a) (defun encode-body (a) a)
(defun extract-mid (a) (defun extract-mid (a)
(lookup "message-id" (parse-headers (article-headers (parse-article a))))) (lookup "message-id" (parse-head (article-head (parse-article a)))))
(defun lookup (key table) (defun lookup (key table)
(cdr (assoc key table :test #'string=))) (cdr (assoc key table :test #'string=)))
@ -527,7 +539,7 @@
((string= cmd "USER") ((string= cmd "USER")
(setf (client-username *client*) arg) (setf (client-username *client*) arg)
(make-response :code 381 :request r (make-response :code 381 :request r
:data (format nil "Hey, ~a, please tell us your password." arg))) :data (fmt "Hey, ~a, please tell us your password." arg)))
((string= cmd "PASS") ((string= cmd "PASS")
(if (authinfo-check (client-username *client*) arg) (if (authinfo-check (client-username *client*) arg)
(progn (progn
@ -566,7 +578,7 @@
(t (multiple-value-bind (group n-str) (lookup-index n-or-mid) (t (multiple-value-bind (group n-str) (lookup-index n-or-mid)
(if (and group n-str) (if (and group n-str)
(funcall fn-name r group n-str) (funcall fn-name r group n-str)
(bad-input r (format nil "Unknown article ~a." n-or-mid)))))))) (bad-input r (fmt "Unknown article ~a." n-or-mid))))))))
(t (bad-input r "No, no: it takes at most two arguments."))))))) (t (bad-input r "No, no: it takes at most two arguments.")))))))
(defun cmd-head (r) (defun cmd-head (r)
@ -582,7 +594,7 @@
(typical-cmd-response 220 r g i #'(lambda (a) (encode-body a)))) (typical-cmd-response 220 r g i #'(lambda (a) (encode-body a))))
(defun head-response (r g i) (defun head-response (r g i)
(typical-cmd-response 221 r g i #'(lambda (a) (article-headers (parse-article a))))) (typical-cmd-response 221 r g i #'(lambda (a) (article-head (parse-article a)))))
(defun body-response (r g i) (defun body-response (r g i)
(typical-cmd-response 222 r g i #'(lambda (a) (encode-body (article-body (parse-article a)))))) (typical-cmd-response 222 r g i #'(lambda (a) (encode-body (article-body (parse-article a))))))
@ -593,16 +605,16 @@
(cond ((null a) (cond ((null a)
(make-response (make-response
:code 400 :request r :code 400 :request r
:data (format nil "article ~a/~a does not exist" g i))) :data (fmt "article ~a/~a does not exist" g i)))
(t (t
(prepend-response-with (prepend-response-with
(format nil "~a ~a" i (extract-mid a)) (fmt "~a ~a" i (extract-mid a))
(make-response :multi-line 'yes :code code (make-response :multi-line 'yes :code code
:request r :data (funcall get-data a)))))) :request r :data (funcall get-data a))))))
(sb-posix:syscall-error (c) (sb-posix:syscall-error (c)
(make-response (make-response
:code 400 :request r :code 400 :request r
:data (format nil "article ~a/~a: ~a" g i c))))) :data (fmt "article ~a/~a: ~a" g i c)))))
(defun cmd-next (r) (defun cmd-next (r)
(with-auth (with-auth
@ -620,7 +632,7 @@
(let ((cur (client-article *client*))) (let ((cur (client-article *client*)))
(make-response :code 223 (make-response :code 223
:request r :request r
:data (format nil "~a ~a" cur (mid-by-name g cur))))) :data (fmt "~a ~a" cur (mid-by-name g cur)))))
(defun mid-by-name (g name) (defun mid-by-name (g name)
(extract-mid (fetch-article g name))) (extract-mid (fetch-article g name)))
@ -667,7 +679,7 @@
(fetch-headers g i))))))))))) (fetch-headers g i)))))))))))
(defun xover-format-line (i hs) (defun xover-format-line (i hs)
(str:concat (format nil "~a~a" i #\tab) (str:concat (fmt "~a~a" i #\tab)
(str:join #\tab (str:join #\tab
(mapcar #'(lambda (h) (get-header h hs)) (mapcar #'(lambda (h) (get-header h hs))
(xover-headers))))) (xover-headers)))))
@ -682,7 +694,7 @@
(with-group g r (with-group g r
(set-group! g) (set-group! g)
(multiple-value-bind (low high len) (group-high-low g) (multiple-value-bind (low high len) (group-high-low g)
(let ((ln (format nil "~a ~a ~a ~a" len low high g))) (let ((ln (fmt "~a ~a ~a ~a" len low high g)))
(setf (client-article *client*) low) (setf (client-article *client*) low)
(make-response :code 211 :request r :data ln)))))))) (make-response :code 211 :request r :data ln))))))))
@ -708,7 +720,7 @@
(reverse (reverse
(mapcar (mapcar
#'(lambda (g) #'(lambda (g)
(format nil "~a ~a ~a y" (group-name g) (group-high g) (group-low g))) (fmt "~a ~a ~a y" (group-name g) (group-high g) (group-low g)))
ls))) ls)))
(defun build-groups-structs () (defun build-groups-structs ()
@ -827,7 +839,7 @@
(defun display-fn (cmd-pair) (defun display-fn (cmd-pair)
(let ((cmd (cdr cmd-pair))) (let ((cmd (cdr cmd-pair)))
(format nil "~A ~A" (fmt "~A ~A"
(command-verb cmd) (command-verb cmd)
(command-description cmd)))) (command-description cmd))))
@ -840,18 +852,29 @@
:data :data
(format-timestring nil (now)))) (format-timestring nil (now))))
(defun conforms? (bs) (defun conforms? (parsed-article)
(catch 'article-syntax-error ;; parse-headers might throw (catch 'article-syntax-error ;; parse-header might throw
(let ((headers (parse-headers (article-headers (parse-article bs))))) (let* ((headers (article-headers parsed-article))
(let ((result (dolist (h (headers-required-from-clients)) (required (dolist (h (headers-required-from-clients))
(when (not (lookup h headers)) (when (not (lookup h headers))
(return (format nil "missing the /~a/ header" h))))) (return (fmt "missing the /~a/ header" h)))))
(content-type (get-header "content-type" headers))) (content-type (get-header "content-type" headers))
(cond (ngs-dont-exist
((stringp result) (values nil result)) (let ((ls)
((not (text/plain? content-type)) (ngs (article-newsgroups parsed-article)))
(values nil (format nil "content-type must be plain/text, but it's ~a" content-type))) (dolist (g ngs)
(t (values t nil))))))) (if (or (not (group-name-conforms? g)) (not (group? g)))
(push g ls))))))
(cond
((stringp required) (values nil required))
((not (text/plain? content-type))
(values nil (fmt "content-type must be plain/text, but it's ~a" content-type)))
((not (zerop (length ngs-dont-exist)))
(values nil (fmt "Sorry. We will not post your article to any newsgroup because "
"the " (word-plural (length ngs-dont-exist) "newsgroup") " "
(str:join ", " (sort ngs-dont-exist #'string<))
" just " (word-plural (length ngs-dont-exist) "doesn't") " exist.")))
(t (values t nil))))))
(defun text/plain? (header-s) (defun text/plain? (header-s)
;; I say T when S begins with "text/plain" or when S is "". ;; I say T when S begins with "text/plain" or when S is "".
@ -866,7 +889,7 @@
'("from" "newsgroups" "subject")) '("from" "newsgroups" "subject"))
(defun suggest-message-id (&optional (n 20)) (defun suggest-message-id (&optional (n 20))
(format nil "<~a@loop>" (random-string n))) (fmt "<~a@loop>" (random-string n)))
(defun random-string (size) (defun random-string (size)
(let* ((universe "abcdefghijklmnopqrstuvwxyz") (let* ((universe "abcdefghijklmnopqrstuvwxyz")
@ -878,80 +901,69 @@
(coerce mid 'string))) (coerce mid 'string)))
(defun unparse-article (parsed) (defun unparse-article (parsed)
(data (coerce
(let ((ls)) (data
(dolist (h (parse-headers (article-headers parsed))) (let ((ls))
(setq ls (cons (data (str:capitalize (car h)) ": " (cdr h) (crlf)) ls))) (dolist (h (parse-head (article-head parsed)))
(nreverse ls)) (setq ls (cons (data (str:capitalize (car h)) ": " (cdr h) (crlf)) ls)))
(crlf) (nreverse ls))
(article-body parsed))) (crlf)
(article-body parsed))
'vector))
(defun ensure-header (h fn bs) (defun enrich-article (parsed-article)
(let* ((headers (parse-headers (article-headers (parse-article bs))))) (ensure-mid (ensure-date parsed-article)))
(if (lookup h headers)
bs (defun ensure-mid (parsed-article)
(unparse-article (ensure-header "message-id" #'suggest-message-id parsed-article))
(make-article
:headers (defun ensure-date (parsed-article)
(str:join (crlf-string) (ensure-header "date" #'get-date parsed-article))
(mapcar #'(lambda (h)
(format nil "~a: ~a" (car h) (cdr h))) (defun ensure-header (header fn-add-header parsed-article)
(cons (cons h (funcall fn)) headers))) (if (lookup header (article-headers parsed-article))
:body (article-body (parse-article bs))))))) parsed-article
(progn
(setf (article-headers parsed-article)
(cons (cons header (funcall fn-add-header))
(article-headers parsed-article)))
parsed-article)))
(defun get-date () (defun get-date ()
(multiple-value-bind (s m h day mon year dow dst-p tz) (multiple-value-bind (s m h day mon year dow dst-p tz)
(get-decoded-time) (get-decoded-time)
(declare (ignore dow dst-p)) (declare (ignore dow dst-p))
(format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d GMT~a" (fmt "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d GMT~a"
year mon day h m s (- tz)))) year mon day h m s (- tz))))
(defun ensure-mid (bs)
(ensure-header "message-id" #'suggest-message-id bs))
(defun ensure-date (bs)
(ensure-header "date" #'get-date bs))
(defun cmd-post (r) (defun cmd-post (r)
(with-auth (with-auth
(send-response! (send-response!
(make-response (make-response
:code 340 :code 340
:data (format nil "Okay, go ahead. Suggested message-id ~a." :data (fmt "Okay, go ahead. Suggested message-id ~a."
(suggest-message-id)))) (suggest-message-id))))
(let* ((bs (nntp-read-article))) (let* ((bs (nntp-read-article))
(multiple-value-bind (okay? error) (conforms? bs) (parsed-article (parse-article bs (client-username *client*))))
(multiple-value-bind (okay? error) (conforms? parsed-article)
(cond ((not okay?) (cond ((not okay?)
(make-response (make-response
:code 400 :request r :code 400 :request r
:data (format nil "Sorry. Your article doesn't conform: ~a." error))) :data (fmt "Sorry. Your article doesn't conform: ~a." error)))
(t (multiple-value-bind (code reply) (post bs) (t
(multiple-value-bind (code reply) (post (enrich-article parsed-article))
(make-response :code code :request r :data reply)))))))) (make-response :code code :request r :data reply))))))))
(defun post (bs) (defun post (parsed-article)
(let ((ngs (newsgroups-header->list (let* ((parsed-article (ensure-date (ensure-mid parsed-article)))
(get-header "newsgroups" (parse-headers (bs (unparse-article parsed-article))
(article-headers (ng (car (article-newsgroups parsed-article))))
(parse-article bs)))))) (save-article-insist ng (get-next-article-id ng) bs)
(ngs-dont-exist)) (update-last-post-date! (client-username *client*)))
(dolist (g ngs)
(if (or (not (group-name-conforms? g))
(not (group? g)))
(push g ngs-dont-exist)))
(if (zerop (length ngs-dont-exist))
(progn
(dolist (ng ngs)
(let ((a (ensure-date (ensure-mid bs))))
(save-article-insist ng (get-next-article-id ng) a (extract-mid a))
(update-last-post-date! (client-username *client*))))
(values 240 (data "Thank you! Your article has been saved.")))
(values 400 (data "Sorry. We did not post your article to any newsgroup because "
"the " (word-plural (length ngs-dont-exist) "newsgroup") " "
(str:join ", " (sort ngs-dont-exist #'string<))
" just " (word-plural (length ngs-dont-exist) "doesn't") " exist.")))))
(defun newsgroups-header->list (s) ;; Now that we've saved the article, it's time to index it.
(mapcar #'(lambda (n) (str:trim (string-downcase n))) (str:split "," s)))
)
(defun update-last-post-date! (username) (defun update-last-post-date! (username)
(let ((u (get-account username))) (let ((u (get-account username)))
@ -961,8 +973,8 @@
(rename-file old (make-pathname :name new :type :unspecific))) (rename-file old (make-pathname :name new :type :unspecific)))
(defun save-article-try (name-try bs) (defun save-article-try (name-try bs)
(let ((name (format nil "~a" name-try)) (let ((name (fmt "~a" name-try))
(tmp (format nil "~a.tmp" name-try))) (tmp (fmt "~a.tmp" name-try)))
(with-open-file (with-open-file
(s name (s name
:direction :output :direction :output
@ -981,11 +993,11 @@
(write-sequence bs s)) (write-sequence bs s))
(rename-no-extension tmp name))) (rename-no-extension tmp name)))
(defun save-article-insist (g name a message-id) (defun save-article-insist (g name bytes)
(loop for name from name do (loop for name from name do
(in-dir (format nil "groups/~a/" g) (in-dir (fmt "groups/~a/" g)
(when (not (eql 'name-exists (save-article-try name a))) (when (not (eql 'name-exists (save-article-try name bs)))
(return (values name (insert-index message-id g (fmt "~a" name)))))))) (return name)))))
(defun get-next-article-id (g) (defun get-next-article-id (g)
(multiple-value-bind (low high len) (group-high-low g) (multiple-value-bind (low high len) (group-high-low g)
@ -1020,7 +1032,7 @@
((stringp d) (string->bytes d)) ((stringp d) (string->bytes d))
((consp d) (list->bytes d)) ((consp d) (list->bytes d))
((vectorp d) (vector->bytes d)) ((vectorp d) (vector->bytes d))
(t (error (format nil "type ~a is not supported" (type-of d)))))) (t (error (fmt "type ~a is not supported" (type-of d))))))
(defun add-crlf-between (ls-of-ls) (defun add-crlf-between (ls-of-ls)
;; Add \r\n to each ``line''. Returns List-of Byte. ;; Add \r\n to each ``line''. Returns List-of Byte.
@ -1039,21 +1051,21 @@
(group-name-conforms? g) (group-name-conforms? g)
(if (not okay?) (if (not okay?)
(make-response :code 580 :request r (make-response :code 580 :request r
:data (format nil "group name does not conform: ~a" reason)) :data (fmt "group name does not conform: ~a" reason))
(progn (progn
(multiple-value-bind (path created?) (multiple-value-bind (path created?)
(in-groups (ensure-directories-exist (concatenate 'string g "/"))) (in-groups (ensure-directories-exist (concatenate 'string g "/")))
(declare (ignore created?)) (declare (ignore created?))
(if (not path) (if (not path)
(make-response :code 581 :request r (make-response :code 581 :request r
:data (format nil "could not create group ~a" :data (fmt "could not create group ~a"
(if (group? g) (if (group? g)
"because it already exists" "because it already exists"
"but we don't know why---sorry!"))) "but we don't know why---sorry!")))
(progn (progn
(notify-group-created g) (notify-group-created g)
(make-response :code 280 :request r (make-response :code 280 :request r
:data (format nil "group ~a created" g))))))))))) :data (fmt "group ~a created" g)))))))))))
(defun group-name-conforms? (g) (defun group-name-conforms? (g)
(conforms-to? g "^[^\\s/]+$")) (conforms-to? g "^[^\\s/]+$"))
@ -1114,7 +1126,7 @@
(defun write-accounts! () (defun write-accounts! ()
(let ((name (let ((name
(let* ((tmp (random-string 10)) (let* ((tmp (random-string 10))
(name (format nil "~a.tmp" tmp))) (name (fmt "~a.tmp" tmp)))
(with-open-file (with-open-file
(s name (s name
:direction :output :direction :output
@ -1124,7 +1136,7 @@
name)))) name))))
(rename-file name "accounts.lisp") (rename-file name "accounts.lisp")
(values t *accounts*) (values t *accounts*)
;(values nil (format nil "could not rename ~a to accounts.lisp" name)) ;(values nil (fmt "could not rename ~a to accounts.lisp" name))
)) ))
(defun get-account (username) (defun get-account (username)
@ -1259,8 +1271,9 @@
(if u (let ((s (account-seen u))) (if u (let ((s (account-seen u)))
(if s (universal-to-human s)))))) (if s (universal-to-human s))))))
(defun cmd-dd (r) (defun cmd-test (r)
(make-response :code 200 :data (format nil "state: ~a" *client*) :request r)) (let ((x (create-symbolic-link "index/<871pw1mm9e.fsf@tor.soy>" "../groups/local.test/15")))
(make-response :code 200 :data (fmt "returned: ~a" x) :request r)))
(defun cmd-repl (r) (defun cmd-repl (r)
(if *enable-nntp-repl* (if *enable-nntp-repl*
@ -1291,14 +1304,14 @@
(in-groups (ensure-directories-exist "local.control.news/")) (in-groups (ensure-directories-exist "local.control.news/"))
(when (group? "local.control.news") (when (group? "local.control.news")
(let ((a (make-news :subject subject :body body))) (let ((a (make-news :subject subject :body body)))
(post (concatenate 'vector (article-headers a) (crlf) (article-body a) (crlf)))))) (post (concatenate 'vector (article-head a) (crlf) (article-body a) (crlf))))))
(defun make-news (&key subject body) (defun make-news (&key subject body)
(make-article (make-article
:headers (data :headers (data
(add-crlf-between (add-crlf-between
(mapcar (mapcar
#'(lambda (p) (data (format nil "~a: ~a" (car p) (cdr p)))) #'(lambda (p) (data (fmt "~a: ~a" (car p) (cdr p))))
`(("from" . "Loop") `(("from" . "Loop")
("subject" . ,subject) ("subject" . ,subject)
("newsgroups" . "local.control.news"))))) ("newsgroups" . "local.control.news")))))
@ -1308,7 +1321,7 @@
(clingon:make-command (clingon:make-command
:name "LOOP" :name "LOOP"
:description "An NNTP server for a circle of friends." :description "An NNTP server for a circle of friends."
:version "a89e088" :version "ec13a0c"
:options (root/options) :options (root/options)
:handler #'root/handlers :handler #'root/handlers
:sub-commands (list (account/command)))) :sub-commands (list (account/command))))
@ -1333,25 +1346,29 @@
:key :logging))) :key :logging)))
(defun root/handlers (cmd) (defun root/handlers (cmd)
(handler-case (root/main cmd)
(root/main cmd) ;; (handler-case
(end-of-file () ;; (root/main cmd)
(print/finish "^d~%") ;; (end-of-file ()
(uiop:quit 0)) ;; (print/finish "^d~%")
(interactive-interrupt () ;; (uiop:quit 0))
(print/finish "^c~%") ;; (interactive-interrupt ()
(uiop:quit 0)))) ;; (print/finish "^c~%")
;; (uiop:quit 0)))
)
(defun root/main (cmd) (defun root/main (cmd)
(let ((args (clingon:command-arguments cmd)) (server-start)
(repl? (clingon:getopt cmd :repl)) ;; (let ((args (clingon:command-arguments cmd))
(logging? (clingon:getopt cmd :logging)) ;; (repl? (clingon:getopt cmd :repl))
(disable-nntp-repl? (clingon:getopt cmd :disable-nntp-repl))) ;; (logging? (clingon:getopt cmd :logging))
(setq *debug* logging?) ;; (disable-nntp-repl? (clingon:getopt cmd :disable-nntp-repl)))
(setq *enable-nntp-repl* (not disable-nntp-repl?)) ;; (setq *debug* logging?)
(when repl? ;; (setq *enable-nntp-repl* (not disable-nntp-repl?))
(return-from root/main (repl (make-request)))) ;; (when repl?
(server-start))) ;; (return-from root/main (repl (make-request))))
;; (server-start))
)
(defun account/command () (defun account/command ()
(clingon:make-command (clingon:make-command
@ -1490,14 +1507,16 @@
(defun main () (defun main ()
(read-accounts!) (read-accounts!)
(create-index!) (create-index!)
(let ((app (root/command))) (server-start)
(clingon:run app))) ;; (let ((app (root/command)))
;; (clingon:run app))
)
(defun send-banner! () (defun send-banner! ()
(send-response! (send-response!
(make-response (make-response
:code 200 :code 200
:data "Welcome! I am LOOP a89e088. Say ``help'' for a menu."))) :data "Welcome! I am LOOP ec13a0c. Say ``help'' for a menu.")))
(setq lisp-unit:*print-failures* t) (setq lisp-unit:*print-failures* t)
(define-test dispatching (define-test dispatching
(assert-true (equalp (empty-response) (dispatch (make-request))))) (assert-true (equalp (empty-response) (dispatch (make-request)))))

411
loop.nw
View file

@ -231,7 +231,7 @@ is responsible to find the correct procedure to reply to the request.
LOOP> (dispatch (make-request :verb "HELP")) LOOP> (dispatch (make-request :verb "HELP"))
#S(RESPONSE #S(RESPONSE
:CODE 400 :CODE 400
:DATA "unrecognized command" :DATA "Unrecognized command."
:REQUEST #S(REQUEST :VERB "HELP" :ARGS NIL :SAID NIL) :REQUEST #S(REQUEST :VERB "HELP" :ARGS NIL :SAID NIL)
:MULTI-LINE NIL) :MULTI-LINE NIL)
\end{verbatim} \end{verbatim}
@ -481,7 +481,7 @@ commands, which is essentially what the user sees when ask for
"creates an account so you can invite a friend") "creates an account so you can invite a friend")
("PASSWD" ,#'cmd-passwd "changes your password") ("PASSWD" ,#'cmd-passwd "changes your password")
("USERS" ,#'cmd-list-users "lists all users") ("USERS" ,#'cmd-list-users "lists all users")
("DD" ,#'cmd-dd "[d]isplays [d]ata: your state of affairs") ("TEST" ,#'cmd-test "runs a developer's experiment")
("QUIT" ,#'cmd-quit "politely says good-bye") ("QUIT" ,#'cmd-quit "politely says good-bye")
("DATE" ,#'cmd-date "displays the current date at this server") ("DATE" ,#'cmd-date "displays the current date at this server")
("UNLOCK-ACCOUNT" ,#'cmd-unlock-account "unlocks an account") ("UNLOCK-ACCOUNT" ,#'cmd-unlock-account "unlocks an account")
@ -507,7 +507,7 @@ commands, which is essentially what the user sees when ask for
:fn #'(lambda (r) :fn #'(lambda (r)
(make-response (make-response
:code 400 :code 400
:data "unrecognized command" :data "Unrecognized command."
:request r)) :request r))
:verb 'unrecognized :verb 'unrecognized
:description "a command for all commands typed wrong"))) :description "a command for all commands typed wrong")))
@ -554,7 +554,7 @@ Here's how to send a [[response]] to a client.
(append seq (append seq
(when (not (= (car (last seq)) 10)) (when (not (= (car (last seq)) 10))
(list 13 10)))) (list 13 10))))
(t (error (format nil "append-crlf-if-needed: unsupported type: ~a" (type-of seq)))))) (t (error (fmt "append-crlf-if-needed: unsupported type: ~a" (type-of seq))))))
(defun send-response! (r) (defun send-response! (r)
(let ((bs (data (integer->string (response-code r)) " " (let ((bs (data (integer->string (response-code r)) " "
@ -625,8 +625,10 @@ itself---so we can cascade actions based on a user's request.
(defun main () (defun main ()
(read-accounts!) (read-accounts!)
(create-index!) (create-index!)
(let ((app (root/command))) (server-start)
(clingon:run app))) ;; (let ((app (root/command)))
;; (clingon:run app))
)
(defun send-banner! () (defun send-banner! ()
(send-response! (send-response!
@ -661,7 +663,7 @@ An NNTP server for a circle of friends.
@ @
<<Version>>= <<Version>>=
a89e088 ec13a0c
@ @
\section{Parsing of requests} \section{Parsing of requests}
@ -741,14 +743,16 @@ In the root command, there's also a list of subcommands.
:key :logging))) :key :logging)))
(defun root/handlers (cmd) (defun root/handlers (cmd)
(handler-case (root/main cmd)
(root/main cmd) ;; (handler-case
(end-of-file () ;; (root/main cmd)
(print/finish "^d~%") ;; (end-of-file ()
(uiop:quit 0)) ;; (print/finish "^d~%")
(interactive-interrupt () ;; (uiop:quit 0))
(print/finish "^c~%") ;; (interactive-interrupt ()
(uiop:quit 0)))) ;; (print/finish "^c~%")
;; (uiop:quit 0)))
)
@ %def root/command @ %def root/command
You've already see root options above and next you'll see options and You've already see root options above and next you'll see options and
@ -806,15 +810,17 @@ have a certain main procedure. So this is it for the root command.
<<Command-line parsing>>= <<Command-line parsing>>=
(defun root/main (cmd) (defun root/main (cmd)
(let ((args (clingon:command-arguments cmd)) (server-start)
(repl? (clingon:getopt cmd :repl)) ;; (let ((args (clingon:command-arguments cmd))
(logging? (clingon:getopt cmd :logging)) ;; (repl? (clingon:getopt cmd :repl))
(disable-nntp-repl? (clingon:getopt cmd :disable-nntp-repl))) ;; (logging? (clingon:getopt cmd :logging))
(setq *debug* logging?) ;; (disable-nntp-repl? (clingon:getopt cmd :disable-nntp-repl)))
(setq *enable-nntp-repl* (not disable-nntp-repl?)) ;; (setq *debug* logging?)
(when repl? ;; (setq *enable-nntp-repl* (not disable-nntp-repl?))
(return-from root/main (repl (make-request)))) ;; (when repl?
(server-start))) ;; (return-from root/main (repl (make-request))))
;; (server-start))
)
@ %def root/main @ %def root/main
We continue with the {\tt account} subcommand. We continue with the {\tt account} subcommand.
@ -985,25 +991,35 @@ posted? We look at the header {\tt newsgroups}. So, the server must
understand the encoding of headers. Therefore, we assume ASCII understand the encoding of headers. Therefore, we assume ASCII
encoding of all headers that we need to parse. encoding of all headers that we need to parse.
The member [[headers]] of the structure [[article]] is just a string, The member [[head]] of the structure [[article]] is just a string,
while body is a vector of bytes. To get a list of pairs out of the while body is a vector of bytes. To get a list of pairs out of the
set of all headers of an article, we can ask [[parse-headers]]. Yes, set of all headers of an article, we can ask [[parse-head]]. All
I should've called the member [[headers]] as [[head]] and not other members of [[article]] are information needed in other places
[[headers]] because both the word ``headers'' and its plural used here such as [[post]].
suggest a list of parsed headers. We're going to rename this in due
time. %% TODO
<<Representation of articles>>= <<Representation of articles>>=
(defstruct article headers body) (defstruct article message-id newsgroups headers username body head)
@ @
<<How to parse articles>>= <<How to parse articles>>=
(defun parse-article (v) (defun parse-article (v &optional (username nil))
(let ((parts (split-vector (vector 13 10 13 10) v nil :limit 2))) (let* ((parts (split-vector (vector 13 10 13 10) v nil :limit 2))
(make-article :headers (map 'string #'code-char (car parts)) :body (cadr parts)))) (head (car parts))
(head-str (map 'string #'code-char head))
(headers (parse-head head-str))
(body (cadr parts))
(mid (lookup "message-id" headers))
(ngs (str:split "," (str:collapse-whitespaces (lookup "newsgroups" headers)))))
(make-article
:headers headers
:message-id mid
:newsgroups ngs
:username username
:head head-str
:body body)))
(defun hs-space-collapsed (hs) (defun hs-space-collapsed (hs)
(cl-ppcre:regex-replace-all (format nil "~a[ ~a]+" (crlf-string) #\tab) hs " ")) (cl-ppcre:regex-replace-all (fmt "~a[ ~a]+" (crlf-string) #\tab) hs " "))
(defun hs-lines (lines) (str:split (crlf-string) lines)) (defun hs-lines (lines) (str:split (crlf-string) lines))
@ -1011,28 +1027,26 @@ time. %% TODO
(let* ((h (str:collapse-whitespaces header)) (let* ((h (str:collapse-whitespaces header))
(pos (search ":" h))) (pos (search ":" h)))
(when (null pos) (when (null pos)
(throw 'article-syntax-error (throw 'article-syntax-error (values nil (fmt "missing colon in header |~a|" h))))
(values nil (format nil "missing colon in header |~a|" h))))
(when (<= (length h) (+ 2 pos)) (when (<= (length h) (+ 2 pos))
(throw 'article-syntax-error (throw 'article-syntax-error (values nil (fmt "empty header ~a" h))))
(values nil (format nil "empty header ~a" h))))
(multiple-value-bind (key val) (multiple-value-bind (key val)
(values (subseq h 0 pos) (subseq h (+ 2 pos))) (values (subseq h 0 pos) (subseq h (+ 2 pos)))
(cons (str:downcase key) val)))) (cons (str:downcase key) val))))
(defun parse-headers (hs) (defun parse-head (hs)
(let ((ls (hs-lines (hs-space-collapsed hs)))) (let ((ls (hs-lines (hs-space-collapsed hs))))
(mapcar #'(lambda (h) (parse-header h)) ls))) (mapcar #'(lambda (h) (parse-header h)) ls)))
(defun string-integer? (s) (ignore-errors (parse-integer s))) (defun string-integer? (s) (ignore-errors (parse-integer s)))
@ %def parse-article parse-headers @ %def parse-article parse-head
We now write some procedures that we use when we're build the {\em We now write some procedures that we use when we're build the {\em
overview} of the command \verb|XOVER|. overview} of the command \verb|XOVER|.
<<How to parse articles>>= <<How to parse articles>>=
(defun get-header-from-article (h a) (defun get-header-from-article (h a)
(get-header h (parse-headers (article-headers (parse-article a))))) (get-header h (parse-head (article-head (parse-article a)))))
(defun get-header (key hs) (defun get-header (key hs)
(let ((pair (assoc key hs :test #'string=))) (let ((pair (assoc key hs :test #'string=)))
@ -1041,13 +1055,13 @@ We now write some procedures that we use when we're build the {\em
(defun fetch-headers (g i) (defun fetch-headers (g i)
(let* ((a-string (fetch-article g i)) (let* ((a-string (fetch-article g i))
(a-parsed (parse-article a-string)) (a-parsed (parse-article a-string))
(headers (parse-headers (article-headers a-parsed)))) (headers (parse-head (article-head a-parsed))))
(enrich-headers headers a-string))) (enrich-headers headers a-string)))
(defun enrich-headers (hs a) (defun enrich-headers (hs a)
(append hs (append hs
`(("line-count" . ,(format nil "~a" (nlines (article-body (parse-article a))))) `(("line-count" . ,(fmt "~a" (nlines (article-body (parse-article a)))))
("byte-count" . ,(format nil "~a" (length a)))))) ("byte-count" . ,(fmt "~a" (length a))))))
(defun nlines (v) (length (split-vector (crlf) v nil))) (defun nlines (v) (length (split-vector (crlf) v nil)))
@ %def get-header fetch-headers @ %def get-header fetch-headers
@ -1062,7 +1076,7 @@ interpreting such bytes. That's why we call [[read-sequence]] here.
<<How to parse articles>>= <<How to parse articles>>=
(defun fetch-article (g i) (defun fetch-article (g i)
(in-groups (in-groups
(read-file-raw (format nil "~a/~a" g i)))) (read-file-raw (fmt "~a/~a" g i))))
(defun read-file-raw (path) (defun read-file-raw (path)
(with-open-file (with-open-file
@ -1092,12 +1106,12 @@ that so far. So we are essentially writing a bug right here.
The procedures [[extract-mid]] and [[lookup]] also belong belong in The procedures [[extract-mid]] and [[lookup]] also belong belong in
this section. Notice that I also wrote [[mid-by-name]], which should this section. Notice that I also wrote [[mid-by-name]], which should
merge with [[extract-mid]]. I think I also wrote more merge with [[extract-mid]]. I think I also wrote more
redundancies---perhaps in the implementatio nof [[xover]]---for not redundancies---perhaps in the implementation of [[xover]]---for not
using [[lookup]]. I need to seek out all such places and organize. %% TODO using [[lookup]]. I need to seek out all such places and organize. %% TODO
<<How to parse articles>>= <<How to parse articles>>=
(defun extract-mid (a) (defun extract-mid (a)
(lookup "message-id" (parse-headers (article-headers (parse-article a))))) (lookup "message-id" (parse-head (article-head (parse-article a)))))
(defun lookup (key table) (defun lookup (key table)
(cdr (assoc key table :test #'string=))) (cdr (assoc key table :test #'string=)))
@ %def extract-mid lookup @ %def extract-mid lookup
@ -1133,7 +1147,7 @@ reason to think we're doing to debug it.}
(defun display-fn (cmd-pair) (defun display-fn (cmd-pair)
(let ((cmd (cdr cmd-pair))) (let ((cmd (cdr cmd-pair)))
(format nil "~A ~A" (fmt "~A ~A"
(command-verb cmd) (command-verb cmd)
(command-description cmd)))) (command-description cmd))))
@ @
@ -1165,7 +1179,7 @@ Syntax error. Say ``authinfo USER /your-name/'' then ``authinfo PASS /your-pass/
((string= cmd "USER") ((string= cmd "USER")
(setf (client-username *client*) arg) (setf (client-username *client*) arg)
(make-response :code 381 :request r (make-response :code 381 :request r
:data (format nil "Hey, ~a, please tell us your password." arg))) :data (fmt "Hey, ~a, please tell us your password." arg)))
((string= cmd "PASS") ((string= cmd "PASS")
(if (authinfo-check (client-username *client*) arg) (if (authinfo-check (client-username *client*) arg)
(progn (progn
@ -1288,7 +1302,7 @@ from there to see what's happening. Not easy.
(defun write-accounts! () (defun write-accounts! ()
(let ((name (let ((name
(let* ((tmp (random-string 10)) (let* ((tmp (random-string 10))
(name (format nil "~a.tmp" tmp))) (name (fmt "~a.tmp" tmp)))
(with-open-file (with-open-file
(s name (s name
:direction :output :direction :output
@ -1298,7 +1312,7 @@ from there to see what's happening. Not easy.
name)))) name))))
(rename-file name "accounts.lisp") (rename-file name "accounts.lisp")
(values t *accounts*) (values t *accounts*)
;(values nil (format nil "could not rename ~a to accounts.lisp" name)) ;(values nil (fmt "could not rename ~a to accounts.lisp" name))
)) ))
(defun get-account (username) (defun get-account (username)
@ -1490,7 +1504,7 @@ even cache the overview of the group.) %% TODO
(reverse (reverse
(mapcar (mapcar
#'(lambda (g) #'(lambda (g)
(format nil "~a ~a ~a y" (group-name g) (group-high g) (group-low g))) (fmt "~a ~a ~a y" (group-name g) (group-high g) (group-low g)))
ls))) ls)))
(defun build-groups-structs () (defun build-groups-structs ()
@ -1631,7 +1645,7 @@ We just need to verify if the group exists and modify [[*client*]].
(with-group g r (with-group g r
(set-group! g) (set-group! g)
(multiple-value-bind (low high len) (group-high-low g) (multiple-value-bind (low high len) (group-high-low g)
(let ((ln (format nil "~a ~a ~a ~a" len low high g))) (let ((ln (fmt "~a ~a ~a ~a" len low high g)))
(setf (client-article *client*) low) (setf (client-article *client*) low)
(make-response :code 211 :request r :data ln)))))))) (make-response :code 211 :request r :data ln))))))))
@ -1676,7 +1690,7 @@ Section~\ref{sec:index} for the implementation of the index.
(t (multiple-value-bind (group n-str) (lookup-index n-or-mid) (t (multiple-value-bind (group n-str) (lookup-index n-or-mid)
(if (and group n-str) (if (and group n-str)
(funcall fn-name r group n-str) (funcall fn-name r group n-str)
(bad-input r (format nil "Unknown article ~a." n-or-mid)))))))) (bad-input r (fmt "Unknown article ~a." n-or-mid))))))))
(t (bad-input r "No, no: it takes at most two arguments."))))))) (t (bad-input r "No, no: it takes at most two arguments.")))))))
(defun cmd-head (r) (defun cmd-head (r)
@ -1689,7 +1703,7 @@ Section~\ref{sec:index} for the implementation of the index.
(defun article-response (r g i) (defun article-response (r g i)
(typical-cmd-response 220 r g i #'(lambda (a) (encode-body a)))) (typical-cmd-response 220 r g i #'(lambda (a) (encode-body a))))
(defun head-response (r g i) (defun head-response (r g i)
(typical-cmd-response 221 r g i #'(lambda (a) (article-headers (parse-article a))))) (typical-cmd-response 221 r g i #'(lambda (a) (article-head (parse-article a)))))
(defun body-response (r g i) (defun body-response (r g i)
(typical-cmd-response 222 r g i #'(lambda (a) (encode-body (article-body (parse-article a)))))) (typical-cmd-response 222 r g i #'(lambda (a) (encode-body (article-body (parse-article a))))))
@ @
@ -1725,16 +1739,16 @@ back to this to-do item.
(cond ((null a) (cond ((null a)
(make-response (make-response
:code 400 :request r :code 400 :request r
:data (format nil "article ~a/~a does not exist" g i))) :data (fmt "article ~a/~a does not exist" g i)))
(t (t
(prepend-response-with (prepend-response-with
(format nil "~a ~a" i (extract-mid a)) (fmt "~a ~a" i (extract-mid a))
(make-response :multi-line 'yes :code code (make-response :multi-line 'yes :code code
:request r :data (funcall get-data a)))))) :request r :data (funcall get-data a))))))
(sb-posix:syscall-error (c) (sb-posix:syscall-error (c)
(make-response (make-response
:code 400 :request r :code 400 :request r
:data (format nil "article ~a/~a: ~a" g i c))))) :data (fmt "article ~a/~a: ~a" g i c)))))
@ %def typical-cmd-response @ %def typical-cmd-response
The command \verb|NEXT| has a slight different semantics. The command \verb|NEXT| has a slight different semantics.
@ -1756,7 +1770,7 @@ The command \verb|NEXT| has a slight different semantics.
(let ((cur (client-article *client*))) (let ((cur (client-article *client*)))
(make-response :code 223 (make-response :code 223
:request r :request r
:data (format nil "~a ~a" cur (mid-by-name g cur))))) :data (fmt "~a ~a" cur (mid-by-name g cur)))))
(defun mid-by-name (g name) (defun mid-by-name (g name)
(extract-mid (fetch-article g name))) (extract-mid (fetch-article g name)))
@ -1812,7 +1826,7 @@ to the last one.
:test #'string=)) :test #'string=))
(fetch-headers g i))))))))))) (fetch-headers g i)))))))))))
(defun xover-format-line (i hs) (defun xover-format-line (i hs)
(str:concat (format nil "~a~a" i #\tab) (str:concat (fmt "~a~a" i #\tab)
(str:join #\tab (str:join #\tab
(mapcar #'(lambda (h) (get-header h hs)) (mapcar #'(lambda (h) (get-header h hs))
(xover-headers))))) (xover-headers)))))
@ -1859,9 +1873,10 @@ shows to the client the internal state of how the server sees it.
I've used only for debugging and it's not really useful any longer. I've used only for debugging and it's not really useful any longer.
I'm going to remove this very soon. I'm going to remove this very soon.
<<Command dd>>= <<Command test>>=
(defun cmd-dd (r) (defun cmd-test (r)
(make-response :code 200 :data (format nil "state: ~a" *client*) :request r)) (let ((x (create-symbolic-link "index/<871pw1mm9e.fsf@tor.soy>" "../groups/local.test/15")))
(make-response :code 200 :data (fmt "returned: ~a" x) :request r)))
@ %def @ %def
\subsection{{\tt POST}}\label{sec:post} \subsection{{\tt POST}}\label{sec:post}
@ -1877,7 +1892,7 @@ must have \verb|message-id|, \verb|subject|, \verb|from|,
<<Command post>>= <<Command post>>=
<<Does an article conform?>> <<Does an article conform?>>
(defun suggest-message-id (&optional (n 20)) (defun suggest-message-id (&optional (n 20))
(format nil "<~a@loop>" (random-string n))) (fmt "<~a@loop>" (random-string n)))
(defun random-string (size) (defun random-string (size)
(let* ((universe "abcdefghijklmnopqrstuvwxyz") (let* ((universe "abcdefghijklmnopqrstuvwxyz")
@ -1890,17 +1905,30 @@ must have \verb|message-id|, \verb|subject|, \verb|from|,
@ @
Sometimes we parse an article and sometimes we want to undo that Sometimes we parse an article and sometimes we want to undo that
parsing. Am I doing something wrong? I wonder. parsing. Am I doing something wrong? Suppose I want to make changes
to the article such as adding a header. I'm going to have to alter
the sequence of bytes. Now, changing the article requires parsing
because I must locate which substructure will be changed. So it makes
sense that I need to parse headers and then return them to a sequence
of bytes after changes. There aren't many reasons for concern here
because the only section of an article that gets changed is the set of
headers. Remember---the body that belongs to the user, so we never
touch it, but the headers belong to the server. To make sure we have
a date header or a message-id header, we have to parse; then, to write
the article to storage, we need to write it back to a sequence of
bytes.
<<Command post>>= <<Command post>>=
(defun unparse-article (parsed) (defun unparse-article (parsed)
(data (coerce
(let ((ls)) (data
(dolist (h (parse-headers (article-headers parsed))) (let ((ls))
(setq ls (cons (data (str:capitalize (car h)) ": " (cdr h) (crlf)) ls))) (dolist (h (parse-head (article-head parsed)))
(nreverse ls)) (setq ls (cons (data (str:capitalize (car h)) ": " (cdr h) (crlf)) ls)))
(crlf) (nreverse ls))
(article-body parsed))) (crlf)
(article-body parsed))
'vector))
@ %def unparse-article @ %def unparse-article
If an article being posted has no \verb|message-id| or \verb|date|, If an article being posted has no \verb|message-id| or \verb|date|,
@ -1910,39 +1938,35 @@ procedures that would generate such headers if they're missing. Right
now, however, we have only these two to worry about. now, however, we have only these two to worry about.
<<Command post>>= <<Command post>>=
(defun ensure-header (h fn bs) (defun enrich-article (parsed-article)
(let* ((headers (parse-headers (article-headers (parse-article bs))))) (ensure-mid (ensure-date parsed-article)))
(if (lookup h headers)
bs (defun ensure-mid (parsed-article)
(unparse-article (ensure-header "message-id" #'suggest-message-id parsed-article))
(make-article
:headers (defun ensure-date (parsed-article)
(str:join (crlf-string) (ensure-header "date" #'get-date parsed-article))
(mapcar #'(lambda (h)
(format nil "~a: ~a" (car h) (cdr h))) (defun ensure-header (header fn-add-header parsed-article)
(cons (cons h (funcall fn)) headers))) (if (lookup header (article-headers parsed-article))
:body (article-body (parse-article bs))))))) parsed-article
(progn
(setf (article-headers parsed-article)
(cons (cons header (funcall fn-add-header))
(article-headers parsed-article)))
parsed-article)))
(defun get-date () (defun get-date ()
(multiple-value-bind (s m h day mon year dow dst-p tz) (multiple-value-bind (s m h day mon year dow dst-p tz)
(get-decoded-time) (get-decoded-time)
(declare (ignore dow dst-p)) (declare (ignore dow dst-p))
(format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d GMT~a" (fmt "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d GMT~a"
year mon day h m s (- tz)))) year mon day h m s (- tz))))
(defun ensure-mid (bs)
(ensure-header "message-id" #'suggest-message-id bs))
(defun ensure-date (bs)
(ensure-header "date" #'get-date bs))
@ %def ensure-mid ensure-date @ %def ensure-mid ensure-date
Now it's time to look at the header \verb|newsgroups|. XXX: we need Now it's time to look at the header \verb|newsgroups|. We can begin
to rewrite this because we have that plan of verifying everything with the name of each group must conform to the expression...
there is to verify up front in [[conforms?]]. So when we invoke
[[post]], there's nothing else to verify. We're verifying in two
places at the same time.
The name of each group must conform to the expression
<<Form of newsgroup names>>= <<Form of newsgroup names>>=
^[^\\s/]+$ ^[^\\s/]+$
@ -1965,15 +1989,17 @@ of trying to stop them.
(send-response! (send-response!
(make-response (make-response
:code 340 :code 340
:data (format nil "Okay, go ahead. Suggested message-id ~a." :data (fmt "Okay, go ahead. Suggested message-id ~a."
(suggest-message-id)))) (suggest-message-id))))
(let* ((bs (nntp-read-article))) (let* ((bs (nntp-read-article))
(multiple-value-bind (okay? error) (conforms? bs) (parsed-article (parse-article bs (client-username *client*))))
(multiple-value-bind (okay? error) (conforms? parsed-article)
(cond ((not okay?) (cond ((not okay?)
(make-response (make-response
:code 400 :request r :code 400 :request r
:data (format nil "Sorry. Your article doesn't conform: ~a." error))) :data (fmt "Sorry. Your article doesn't conform: ~a." error)))
(t (multiple-value-bind (code reply) (post bs) (t
(multiple-value-bind (code reply) (post (enrich-article parsed-article))
(make-response :code code :request r :data reply)))))))) (make-response :code code :request r :data reply))))))))
@ @
@ -1994,42 +2020,18 @@ refuse posting and return a 400 code with a message describing which
group names failed. Otherwise we save the article. group names failed. Otherwise we save the article.
<<Command post>>= <<Command post>>=
(defun post (bs) (defun post (parsed-article)
(let ((ngs (newsgroups-header->list (let* ((parsed-article (ensure-date (ensure-mid parsed-article)))
(get-header "newsgroups" (parse-headers (bs (unparse-article parsed-article))
(article-headers (ng (car (article-newsgroups parsed-article))))
(parse-article bs)))))) (save-article-insist ng (get-next-article-id ng) bs)
(ngs-dont-exist)) (update-last-post-date! (client-username *client*)))
(dolist (g ngs)
(if (or (not (group-name-conforms? g))
(not (group? g)))
(push g ngs-dont-exist)))
(if (zerop (length ngs-dont-exist))
(progn
(dolist (ng ngs)
(let ((a (ensure-date (ensure-mid bs))))
(save-article-insist ng (get-next-article-id ng) a (extract-mid a))
(update-last-post-date! (client-username *client*))))
(values 240 (data "Thank you! Your article has been saved.")))
(values 400 (data "Sorry. We did not post your article to any newsgroup because "
"the " (word-plural (length ngs-dont-exist) "newsgroup") " "
(str:join ", " (sort ngs-dont-exist #'string<))
" just " (word-plural (length ngs-dont-exist) "doesn't") " exist.")))))
(defun newsgroups-header->list (s) ;; Now that we've saved the article, it's time to index it.
(mapcar #'(lambda (n) (str:trim (string-downcase n))) (str:split "," s)))
)
@ %def post @ %def post
XXX: notice we parse the article again to extract information from it
that we need during [[post]]. That's not only a waste of
time---because we already did that---, but it makes [[post]] a lot
less generic. Perhaps [[conforms?]] should return a data structure
that contains all that [[post]] needs. Then [[post]] consumes that
and saves the article more easily. That's a better idea. I think
[[post]] should not even use variables such as [[*client*]]. The
username to which to update the last-seen date should be included in
the data structure.
<<Command post>>= <<Command post>>=
(defun update-last-post-date! (username) (defun update-last-post-date! (username)
(let ((u (get-account username))) (let ((u (get-account username)))
@ -2053,8 +2055,8 @@ renaming it sounds more like the Right Thing to do.
(rename-file old (make-pathname :name new :type :unspecific))) (rename-file old (make-pathname :name new :type :unspecific)))
(defun save-article-try (name-try bs) (defun save-article-try (name-try bs)
(let ((name (format nil "~a" name-try)) (let ((name (fmt "~a" name-try))
(tmp (format nil "~a.tmp" name-try))) (tmp (fmt "~a.tmp" name-try)))
(with-open-file (with-open-file
(s name (s name
:direction :output :direction :output
@ -2080,11 +2082,11 @@ allocated. Notice that the argument [[name]] is an integer, so
[[name]] is incremented at each iteration. [[name]] is incremented at each iteration.
<<Command post>>= <<Command post>>=
(defun save-article-insist (g name a message-id) (defun save-article-insist (g name bytes)
(loop for name from name do (loop for name from name do
(in-dir (format nil "groups/~a/" g) (in-dir (fmt "groups/~a/" g)
(when (not (eql 'name-exists (save-article-try name a))) (when (not (eql 'name-exists (save-article-try name bs)))
(return (values name (insert-index message-id g (fmt "~a" name)))))))) (return name)))))
(defun get-next-article-id (g) (defun get-next-article-id (g)
(multiple-value-bind (low high len) (group-high-low g) (multiple-value-bind (low high len) (group-high-low g)
@ -2142,7 +2144,7 @@ never comes from the NNTP protocol because there's is always a {\tt
((stringp d) (string->bytes d)) ((stringp d) (string->bytes d))
((consp d) (list->bytes d)) ((consp d) (list->bytes d))
((vectorp d) (vector->bytes d)) ((vectorp d) (vector->bytes d))
(t (error (format nil "type ~a is not supported" (type-of d)))))) (t (error (fmt "type ~a is not supported" (type-of d))))))
(defun add-crlf-between (ls-of-ls) (defun add-crlf-between (ls-of-ls)
;; Add \r\n to each ``line''. Returns List-of Byte. ;; Add \r\n to each ``line''. Returns List-of Byte.
@ -2163,29 +2165,52 @@ network of servers---so we're leaving that out for now. The header
\verb|message-id| is added by \Lp\ if the client doesn't write it \verb|message-id| is added by \Lp\ if the client doesn't write it
itself. itself.
Let's criticize the writing of [[conforms?]]. We have a [[catch]] The way we're writing [[conforms?]], and the way to read it, is we do
here and a [[throw]] in [[parse-headers]]. We also have a [[return]] a bunch of checks in the [[let*]] form, all the checks we want to do.
here. It's getting hard to read this procedure because it's not easy Then in the [[cond]], we react to the results. This strategy allows
to know that a procedure has to return a certain value to match the us to report all problems found, not just the first, but I believe we
expectation of another procedure. I don't remember what [[catch]] should not report too much to the client: these reports are usually
does. I need to review this and then add the explanation for myself. presented in a alert-like pop-up window with an okay button. But we
If I don't remember how this works, other beginners won't know it could report everything.
either. %% TODO
<<Does an article conform?>>= <<Does an article conform?>>=
(defun conforms? (bs) (defun conforms? (parsed-article)
(catch 'article-syntax-error ;; parse-headers might throw (catch 'article-syntax-error ;; parse-header might throw
(let ((headers (parse-headers (article-headers (parse-article bs))))) (let* ((headers (article-headers parsed-article))
(let ((result (dolist (h (headers-required-from-clients)) (required (dolist (h (headers-required-from-clients))
(when (not (lookup h headers)) (when (not (lookup h headers))
(return (format nil "missing the /~a/ header" h))))) (return (fmt "missing the /~a/ header" h)))))
(content-type (get-header "content-type" headers))) (content-type (get-header "content-type" headers))
(cond (ngs-dont-exist
((stringp result) (values nil result)) (let ((ls)
((not (text/plain? content-type)) (ngs (article-newsgroups parsed-article)))
(values nil (format nil "content-type must be plain/text, but it's ~a" content-type))) (dolist (g ngs)
(t (values t nil))))))) (if (or (not (group-name-conforms? g)) (not (group? g)))
(push g ls))))))
(cond
((stringp required) (values nil required))
((not (text/plain? content-type))
(values nil (fmt "content-type must be plain/text, but it's ~a" content-type)))
((not (zerop (length ngs-dont-exist)))
(values nil (fmt "Sorry. We will not post your article to any newsgroup because "
"the " (word-plural (length ngs-dont-exist) "newsgroup") " "
(str:join ", " (sort ngs-dont-exist #'string<))
" just " (word-plural (length ngs-dont-exist) "doesn't") " exist.")))
(t (values t nil))))))
@ %def conforms?
What's this [[catch]] doing here? I need to remember how it works. A
catch form is completely replaced by the value {\em thrown}. So it's
a very powerful non-local exit. Any [[throw]] executed in the {\em
extent} of a [[catch]] form can be seen as a last expression of the
entire [[catch]] form. Notice that [[conforms?]] always ends by
returning some values. This means that any throws within the extent
of the catch of [[conforms?]] must take the same form, otherwise we
would surprise the callees of [[conforms?]]. For the definition of
``extent'', see chapter 3 of the second edition of ``Common Lisp, The
Language'' by Guy L.~Steele, 1984.
<<Does an article conform?>>=
(defun text/plain? (header-s) (defun text/plain? (header-s)
;; I say T when S begins with "text/plain" or when S is "". ;; I say T when S begins with "text/plain" or when S is "".
(let* ((s (str:collapse-whitespaces header-s)) (let* ((s (str:collapse-whitespaces header-s))
@ -2203,22 +2228,7 @@ Notice that up to this point we've only verified if the necessary
headers are present. The \verb|newsgroups| header is a direct headers are present. The \verb|newsgroups| header is a direct
influence to the article storage. For instance, \verb|newsgroups| influence to the article storage. For instance, \verb|newsgroups|
must mention only groups that exist. When we save the article, we must mention only groups that exist. When we save the article, we
check each group. If at least one group exists, we save the article; check each group.
if at least one group doesn't exist, we report to the user all groups
that don't exist, but we do save the article if at least one does
exist. That's probably not the best thing to do. We should probably
warn the user that one group doesn't exist because that could make all
the difference to the user. For instance, someone might decide not to
post at all if they can't cross post to all the groups they wish to.
One typo in one group name and the article would be posted to some
groups, but not to the misstyped one. We need to change this. %% TODO
Also, do notice that to simplify matters we're duplicating articles
cross-posted. What we should do is write the article to the first
group in the list of \verb|newsgroups| and then make a symbolic link
to all others. The problem is that I don't know how to do that on
Windows. I'm not sure if Windows supports symbolic links at all. We
could perhaps duplicate articles only when on Windows. %% TODO
\subsection{{\tt CREATE-GROUP}} \subsection{{\tt CREATE-GROUP}}
@ -2237,21 +2247,21 @@ all or it has been discussed with the community beforehand.
(group-name-conforms? g) (group-name-conforms? g)
(if (not okay?) (if (not okay?)
(make-response :code 580 :request r (make-response :code 580 :request r
:data (format nil "group name does not conform: ~a" reason)) :data (fmt "group name does not conform: ~a" reason))
(progn (progn
(multiple-value-bind (path created?) (multiple-value-bind (path created?)
(in-groups (ensure-directories-exist (concatenate 'string g "/"))) (in-groups (ensure-directories-exist (concatenate 'string g "/")))
(declare (ignore created?)) (declare (ignore created?))
(if (not path) (if (not path)
(make-response :code 581 :request r (make-response :code 581 :request r
:data (format nil "could not create group ~a" :data (fmt "could not create group ~a"
(if (group? g) (if (group? g)
"because it already exists" "because it already exists"
"but we don't know why---sorry!"))) "but we don't know why---sorry!")))
(progn (progn
(notify-group-created g) (notify-group-created g)
(make-response :code 280 :request r (make-response :code 280 :request r
:data (format nil "group ~a created" g))))))))))) :data (fmt "group ~a created" g)))))))))))
(defun group-name-conforms? (g) (defun group-name-conforms? (g)
(conforms-to? g "<<Form of newsgroup names>>")) (conforms-to? g "<<Form of newsgroup names>>"))
@ -2311,14 +2321,14 @@ invitations {\em et cetera} are published there.
(in-groups (ensure-directories-exist "local.control.news/")) (in-groups (ensure-directories-exist "local.control.news/"))
(when (group? "local.control.news") (when (group? "local.control.news")
(let ((a (make-news :subject subject :body body))) (let ((a (make-news :subject subject :body body)))
(post (concatenate 'vector (article-headers a) (crlf) (article-body a) (crlf)))))) (post (concatenate 'vector (article-head a) (crlf) (article-body a) (crlf))))))
(defun make-news (&key subject body) (defun make-news (&key subject body)
(make-article (make-article
:headers (data :headers (data
(add-crlf-between (add-crlf-between
(mapcar (mapcar
#'(lambda (p) (data (format nil "~a: ~a" (car p) (cdr p)))) #'(lambda (p) (data (fmt "~a: ~a" (car p) (cdr p))))
`(("from" . "Loop") `(("from" . "Loop")
("subject" . ,subject) ("subject" . ,subject)
("newsgroups" . "local.control.news"))))) ("newsgroups" . "local.control.news")))))
@ -2459,6 +2469,7 @@ transaction ourselves and in Lisp that's easy with [[unwind-protect]].
(defun insert-index (m g i) (defun insert-index (m g i)
(let ((from (fmt "index/~a" m)) (let ((from (fmt "index/~a" m))
(to (fmt "../groups/~a/~a" g i))) (to (fmt "../groups/~a/~a" g i)))
(stderr "Creating link from ~a to ~a...~%" from to)
(create-symbolic-link from to))) (create-symbolic-link from to)))
@ %def insert-index. @ %def insert-index.
@ -2748,7 +2759,7 @@ any more.
(,r-var ,r)) (,r-var ,r))
(if (not (group? ,g-var)) (if (not (group? ,g-var))
(make-response :code 411 :request ,r-var (make-response :code 411 :request ,r-var
:data (format nil "no such group ``~a''" ,g-var)) :data (fmt "No such group ``~a''." ,g-var))
(progn ,@body))))) (progn ,@body)))))
(defmacro with-n-args (n r &rest body) (defmacro with-n-args (n r &rest body)
@ -2837,20 +2848,20 @@ means 2 bytes. So our conversion is just removing the first byte.
(make-response :code (or code 400) :data msg :request r)) (make-response :code (or code 400) :data msg :request r))
(defun integer->string (n) (defun integer->string (n)
(format nil "~a" n)) (fmt "~a" n))
(defun mkstr (&rest args) ;; a utility (defun mkstr (&rest args)
(with-output-to-string (s) (with-output-to-string (s)
(dolist (a args) (princ a s)))) (dolist (a args) (princ a s))))
(defun data (&rest args) ;; a utility (defun data (&rest args)
(flatten (map 'list #'data->bytes args))) (flatten (map 'list #'data->bytes args)))
(defun crlf () (defun crlf ()
(vector 13 10)) (vector 13 10))
(defun crlf-string () (defun crlf-string ()
(format nil "~c~c" #\return #\linefeed)) (fmt "~c~c" #\return #\linefeed))
(defun flatten (obj) (defun flatten (obj)
(do* ((result (list obj)) (do* ((result (list obj))
@ -3022,7 +3033,8 @@ something to think about.
(:use :common-lisp :local-time) (:use :common-lisp :local-time)
(:import-from :lisp-unit define-test assert-true) (:import-from :lisp-unit define-test assert-true)
(:import-from :org.shirakumo.filesystem-utils (:import-from :org.shirakumo.filesystem-utils
directory-p list-directories list-files) directory-p list-directories list-files
create-symbolic-link)
(:import-from :sb-sys interactive-interrupt) (:import-from :sb-sys interactive-interrupt)
(:export :main)) (:export :main))
@ -3058,7 +3070,7 @@ something to think about.
<<Command login>> <<Command login>>
<<Command passwd>> <<Command passwd>>
<<Command users>> <<Command users>>
<<Command dd>> <<Command test>>
<<Command repl>> <<Command repl>>
<<Broadcasting>> <<Broadcasting>>
<<Command-line parsing>> <<Command-line parsing>>
@ -3168,12 +3180,23 @@ usage()
test $# -lt 2 && usage test $# -lt 2 && usage
tag="$1"; shift tag="$1"; shift
sed "/<<Version>>=/ { sed "/@<<Version@>>=/ {
n; n
c\\ c\\
$tag $tag
}" "$@" }" "$@"
@ @ %def make-release
Make sure to notice that {\tt sed} is not looking for something that
begins with the at-symbol. That at-symbol is there because otherwise
NOWEB would replace the NOWEB version tag with a version---defined in
this very document. I agree that this is confusing, but I'm a student
of NOWEB, so I'm going forward with it no matter how complicated or
confusing it might be: I'm trying to see how extreme literate
programming can be taken. Have a look at the program {\tt
make-release} to see what {\tt sed} really does. What's complicated
is keeping the {\tt make-release} source code in a NOWEB file---such
is the life of a hacker.
\section*{Index of chunks} \section*{Index of chunks}
\nowebchunks \nowebchunks

4
make-release
View file

@ -8,8 +8,8 @@ usage()
test $# -lt 2 && usage test $# -lt 2 && usage
tag="$1"; shift tag="$1"; shift
sed "/a89e088=/ { sed "/<<Version>>=/ {
n; n
c\\ c\\
$tag $tag
}" "$@" }" "$@"