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*{*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
illustrated in Figures~\ref{fg:gnus}fg:gnus319,12490
Section~\ref{sec:repl}sec:repl323,12759
\section{NNTP protocol}NNTP328,12992
\section{It's a network server}It's342,13734
through the command line as illustrated in Section~\ref{sec:design}sec:design369,15206
\section{REPL for \lp}\label{sec:repl}REPL371,15276
\section{Representation of a client}Representation437,17374
\section{Representation of a command}Representation449,17770
\section{Representation of requests and responses}Representation517,20737
\section{Main loop}Main594,23947
\section{Parsing of requests}Parsing669,25880
\section{Parsing of command-line arguments}Parsing688,26641
\section{Request dispatching mechanism}Request961,36913
\section{Representation and parsing of articles}Representation982,37706
\section{How to extract articles from the database}How1065,40809
\section{Commands}Commands1115,42605
\subsection{{\tt HELP}}1117,42625
\subsection{{\tt AUTHINFO}}\label{sec:authinfo}1151,43910
Section~\ref{sec:login}sec:login1157,44202
\subsection{{\tt CREATE-ACCOUNT}}1202,45894
\subsection{{\tt UNLOCK-ACCOUNT}}1320,50452
\ref{sec:inactive-users}sec:inactive-users1323,50541
\subsection{{\tt LOGIN}}\label{sec:login}1356,51852
Besides {\tt AUTHINFO} in Section~\ref{sec:authinfo}sec:authinfo1358,51895
\subsection{{\tt PASSWD}}\label{sec:passwd}1384,52856
\subsection{{\tt USERS}}\label{sec:users}1430,54730
\subsection{{\tt LIST}}\label{sec:list}1480,56381
\subsection{{\tt GROUP}}\label{sec:group}1632,62446
\subsection{{\tt BODY}, {\tt HEAD}, {\tt ARTICLE} e {\tt NEXT}}1662,63270
\label{sec:typical-cmds}sec:typical-cmds1663,63334
Section~\ref{sec:index}sec:index1673,63902
\subsection{{\tt XOVER}}\label{sec:xover}1775,68503
\subsection{{\tt MODE READER}}\label{sec:mode-reader}1833,71074
\subsection{{\tt DATE}}\label{sec:date}1842,71321
\subsection{{\tt QUIT}}\label{sec:quit}1855,71664
\subsection{{\tt DD}}\label{sec:dd}1865,71927
\subsection{{\tt POST}}\label{sec:post}1878,72420
\subsection{{\tt CREATE-GROUP}}2241,87684
\subsection{{\tt REPL}}2278,89424
\section{Publication of news}Publication2305,90274
\section{Algorithm of {\tt split-vector}}Algorithm2346,91833
\section{Article index}\label{sec:index}Article2377,93028
\section{Essential operations relative to the index}Essential2457,96627
\section{Procedure to import the index from the file system}Procedure2502,98639
\section{Deletion and locking of inactive accounts}\label{sec:inactive-users}Deletion2568,100703
\section{Macros to ease writing}\label{sec:dsl}Macros2734,107284
\section{Other procedures}Other2797,109416
\section{Tests}Tests2887,112172
\section{Executable, how to build it}Executable,2960,115048
\section{Log of \lp's communication, how to produce it}Log2981,115628
\section{Package {\tt loop.lisp} as the compiler needs it}Package3018,116977
\section{Other source code}Other3118,120026
\section*{*3209,123229
\section*{*3212,123270
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
loop.nw,7251
(defun repl 406,16344
(defstruct client 444,17635
(defparameter *client* 445,17707
(defstruct command 460,18266
(defparameter *commands-assoc* 461,18306
(defun table-of-commands 465,18369
(defun set-up-tables! 490,19679
(defun get-command 503,20175
(defstruct request 532,21437
(defstruct response 533,21472
(defun empty-response 537,21569
(defun prepend-response-with 538,21648
(defun append-crlf-if-needed 549,22038
(defun send-response! 559,22358
(defun my-write 588,23770
(defun main-loop 609,24648
(defun request-quit? 617,24871
(defun response-quit? 618,24938
(defun server-start 620,25011
(defun main 625,25086
(defun send-banner! 633,25219
(defun parse-request 676,26130
(defun root/command 717,28103
(defun root/options 726,28330
(defun root/handlers 745,28781
(defun root/main 812,31505
(defun account/command 829,32050
(defun account/options 836,32217
(defun account/manager 880,33246
(defun account/list-accounts 929,35415
(defun account/create-account! 932,35499
(defun account/change-passwd! 948,36285
(defun dispatch 972,37440
(defun dispatch-line 978,37595
(defstruct article 1001,38661
(defun parse-article 1005,38761
(defun hs-space-collapsed 1017,39117
(defun hs-lines 1020,39233
(defun parse-header 1022,39291
(defun parse-head 1033,39765
(defun string-integer? 1037,39888
(defun get-header-from-article 1044,40120
(defun get-header 1047,40222
(defun fetch-headers 1051,40328
(defun enrich-headers 1057,40538
(defun nlines 1062,40720
(defun fetch-article 1073,41166
(defun read-file-raw 1077,41253
(defun fetch-body 1088,41548
(defun encode-body 1099,42004
(defun extract-mid 1109,42415
(defun lookup 1111,42509
(defun cmd-help 1132,43409
(defun menu 1140,43672
(defun display-fn 1144,43750
(defun cmd-authinfo 1167,44575
(defun authinfo-check 1189,45558
(defun auth? 1192,45627
(defun log-user-in! 1195,45681
(defun user-name-conforms? 1222,46556
(defun cmd-create-account 1226,46661
(defstruct account 1243,47431
(defparameter *accounts* 1244,47525
(defun read-accounts! 1248,47602
(defun string->array 1256,47799
(defun string->sha256 1261,47960
(defun new-account! 1265,48108
(defun write-accounts! 1298,49724
(defun get-account 1314,50246
(defun cmd-unlock-account 1327,50650
(defun unlock-account! 1344,51440
(defun cmd-login 1364,52175
(defun log-user-in-as! 1379,52743
(defun cmd-passwd 1391,53128
(defun pass? 1410,54030
(defun change-passwd! 1421,54453
(defun cmd-list-users 1436,54874
(defun size-of-longest-username 1444,55101
(defun list-users 1448,55216
(defun universal-to-human 1468,56050
(defun last-time-seen 1474,56169
(defstruct group 1490,56831
(defun cmd-list 1492,56864
(defun build-groups-lines 1499,57124
(defun build-groups-structs 1506,57288
(defun between? 1513,57553
(defun filesize 1517,57628
(defun zero-file? 1521,57700
(defun temporary-article? 1524,57751
(defun article-ready? 1528,57860
(defun get-articles 1533,57977
(defun group-high-low 1543,58365
(defun articles->integers 1550,58592
(defun list-groups 1557,58829
(defun last-char 1562,59026
(defun basename 1570,59239
(defun loop-directory* 1591,60259
(defun loop-list-files 1601,60921
(defun loop-list-directories 1610,61276
(defun cmd-group 1637,62577
(defun group? 1648,62987
(defun xgroup? 1652,63057
(defun set-group! 1655,63097
(defun typical-cmd-head-body-article 1676,63998
(defun cmd-head 1692,64865
(defun cmd-body 1694,64938
(defun cmd-article 1696,65011
(defun article-response 1699,65091
(defun head-response 1701,65190
(defun body-response 1703,65303
(defun typical-cmd-response 1732,66889
(defun cmd-next 1753,67671
(defun article-next! 1764,68125
(defun mid-by-name 1771,68392
(defun cmd-xover 1784,68864
(defun xover 1803,69821
(defun xover-format-line 1824,70743
(defun xover-headers 1829,70965
(defun cmd-mode 1838,71220
(defun cmd-date 1848,71508
(defun cmd-quit 1861,71841
(defun cmd-test 1873,72224
(defun suggest-message-id 1890,72964
(defun random-string 1893,73056
(defun unparse-article 1907,73469
(defun ensure-header 1924,74079
(defun get-date 1937,74556
(defun ensure-mid 1944,74798
(defun ensure-date 1946,74877
(defun cmd-post 1974,75958
(defun post 2009,77527
(defun newsgroups-header->list 2033,78605
(defun update-last-post-date! 2048,79301
(defun rename-no-extension 2066,80230
(defun save-article-try 2069,80333
(defun save-article-insist 2103,81607
(defun get-next-article-id 2109,81828
(defun nntp-read-article 2125,82527
(defun nntp-read-line 2144,83403
(defun list->bytes 2153,83766
(defun vector->bytes 2156,83820
(defun data->bytes 2159,83889
(defun add-crlf-between 2167,84158
(defun string->bytes 2171,84310
(defun bytes->string 2174,84365
(defun conforms? 2194,85304
(defun text/plain? 2207,85952
(defun headers-required-from-clients 2216,86295
(defun cmd-create-group 2251,88133
(defun group-name-conforms? 2274,89300
(defun cmd-repl 2284,89577
(defparameter *enable-nntp-repl* 2302,90234
(defun notify-group-created 2312,90507
(defun notify-user-created 2317,90718
(defun notify-user-unlocked 2322,90916
(defun post-notification 2328,91133
(defun make-news 2334,91423
(defun split-vector 2357,92329
(defun split-vector-helper 2361,92471
(defun create-index! 2411,94531
(defun rm-rf 2414,94595
(defun drop-create-index! 2417,94676
(defun insert-index 2477,97606
(defun lookup-index 2494,98361
(defun index-from-fs! 2524,99476
(defun remake-index-from-fs 2533,99889
(defun remove-inactive-users! 2592,101636
(defun remove-account! 2628,103539
(defun lock-account! 2636,103831
(defun loop-epoch 2652,104565
(defun migrate-add-creation-and-post-date! 2655,104626
(defparameter *months-inactive-allowed* 2677,105392
(defparameter *months-never-logged-in* 2678,105435
(defun user-inactive? 2682,105521
(defun inactive-from-never-logged-in? 2686,105647
(defun locked? 2693,105901
(defun inactive-from-last-post? 2696,105988
(defun inactive-from-last-seen? 2704,106346
(defun inactive-from? 2713,106695
(defun ever-logged-in? 2721,106902
(defun never-logged-in? 2724,106978
(defun list-inactive-users 2727,107050
(defmacro in-dir 2742,107560
(defmacro in-groups 2756,108079
(defun in-group-lambda 2758,108141
(defmacro in-group 2760,108197
(defmacro with-group 2763,108297
(defmacro with-n-args 2773,108619
(defmacro with-group-set 2783,108996
(defmacro with-auth 2790,109201
(defun conforms-to? 2808,109948
(defun print/finish 2815,110199
(defun word-plural 2819,110285
(defun plural 2826,110536
(defun out 2833,110720
(defun stderr 2836,110791
(defun stdout 2841,110917
(defun println 2844,110993
(defun enumerate 2847,111105
(defun ucs-2->ascii 2851,111222
(defun bad-input 2855,111319
(defun integer->string 2858,111416
(defun mkstr 2861,111467
(defun data 2865,111572
(defun crlf 2868,111655
(defun crlf-string 2871,111689
(defun flatten 2874,111755
(defmacro mac 2883,112041
(define-test dispatching2918,113875
(defun unix->nntp 2921,113970
(defvar a-post 2925,114082
(defvar a-bad-post 2933,114231
(define-test post-wrong-newsgroup2941,114426
(define-test post-okay2946,114593
(defpackage #:loop3040,118020
(defparameter *debug* 3090,119274
(asdf:defsystem :<<Name>>3111,119857

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

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

2
loop.asd
View file

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

301
loop.lisp
View file

@ -9,7 +9,8 @@
(:use :common-lisp :local-time)
(:import-from :lisp-unit define-test assert-true)
(: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)
(:export :main))
@ -24,7 +25,7 @@
(defstruct response code data request multi-line)
(defstruct command fn verb description)
(defparameter *commands-assoc* nil)
(defstruct article headers body)
(defstruct article message-id newsgroups headers username body head)
(defparameter *months-inactive-allowed* 3)
(defparameter *months-never-logged-in* 1)
(defparameter *enable-nntp-repl* t)
@ -48,7 +49,7 @@
"creates an account so you can invite a friend")
("PASSWD" ,#'cmd-passwd "changes your password")
("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")
("DATE" ,#'cmd-date "displays the current date at this server")
("UNLOCK-ACCOUNT" ,#'cmd-unlock-account "unlocks an account")
@ -74,7 +75,7 @@
:fn #'(lambda (r)
(make-response
:code 400
:data "unrecognized command"
:data "Unrecognized command."
:request r))
:verb 'unrecognized
:description "a command for all commands typed wrong")))
@ -99,7 +100,7 @@
(,r-var ,r))
(if (not (group? ,g-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)))))
(defmacro with-n-args (n r &rest body)
@ -175,20 +176,20 @@
(make-response :code (or code 400) :data msg :request r))
(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)
(dolist (a args) (princ a s))))
(defun data (&rest args) ;; a utility
(defun data (&rest args)
(flatten (map 'list #'data->bytes args)))
(defun crlf ()
(vector 13 10))
(defun crlf-string ()
(format nil "~c~c" #\return #\linefeed))
(fmt "~c~c" #\return #\linefeed))
(defun flatten (obj)
(do* ((result (list obj))
@ -249,7 +250,7 @@
(append seq
(when (not (= (car (last seq)) 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)
(let ((bs (data (integer->string (response-code r)) " "
@ -282,6 +283,7 @@
(defun insert-index (m g i)
(let ((from (fmt "index/~a" m))
(to (fmt "../groups/~a/~a" g i)))
(stderr "Creating link from ~a to ~a...~%" from to)
(create-symbolic-link from to)))
(defun lookup-index (mid)
@ -433,12 +435,24 @@
(drop-create-index!)
(index-from-fs!))
(defun parse-article (v)
(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))))
(defun parse-article (v &optional (username nil))
(let* ((parts (split-vector (vector 13 10 13 10) v nil :limit 2))
(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)
(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))
@ -446,23 +460,21 @@
(let* ((h (str:collapse-whitespaces header))
(pos (search ":" h)))
(when (null pos)
(throw 'article-syntax-error
(values nil (format nil "missing colon in header |~a|" h))))
(throw 'article-syntax-error (values nil (fmt "missing colon in header |~a|" h))))
(when (<= (length h) (+ 2 pos))
(throw 'article-syntax-error
(values nil (format nil "empty header ~a" h))))
(throw 'article-syntax-error (values nil (fmt "empty header ~a" h))))
(multiple-value-bind (key val)
(values (subseq h 0 pos) (subseq h (+ 2 pos)))
(cons (str:downcase key) val))))
(defun parse-headers (hs)
(defun parse-head (hs)
(let ((ls (hs-lines (hs-space-collapsed hs))))
(mapcar #'(lambda (h) (parse-header h)) ls)))
(defun string-integer? (s) (ignore-errors (parse-integer s)))
(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)
(let ((pair (assoc key hs :test #'string=)))
@ -471,19 +483,19 @@
(defun fetch-headers (g i)
(let* ((a-string (fetch-article g i))
(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)))
(defun enrich-headers (hs a)
(append hs
`(("line-count" . ,(format nil "~a" (nlines (article-body (parse-article a)))))
("byte-count" . ,(format nil "~a" (length a))))))
`(("line-count" . ,(fmt "~a" (nlines (article-body (parse-article a)))))
("byte-count" . ,(fmt "~a" (length a))))))
(defun nlines (v) (length (split-vector (crlf) v nil)))
(defun fetch-article (g i)
(in-groups
(read-file-raw (format nil "~a/~a" g i))))
(read-file-raw (fmt "~a/~a" g i))))
(defun read-file-raw (path)
(with-open-file
@ -502,7 +514,7 @@
(defun encode-body (a) 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)
(cdr (assoc key table :test #'string=)))
@ -527,7 +539,7 @@
((string= cmd "USER")
(setf (client-username *client*) arg)
(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")
(if (authinfo-check (client-username *client*) arg)
(progn
@ -566,7 +578,7 @@
(t (multiple-value-bind (group n-str) (lookup-index n-or-mid)
(if (and 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.")))))))
(defun cmd-head (r)
@ -582,7 +594,7 @@
(typical-cmd-response 220 r g i #'(lambda (a) (encode-body a))))
(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)
(typical-cmd-response 222 r g i #'(lambda (a) (encode-body (article-body (parse-article a))))))
@ -593,16 +605,16 @@
(cond ((null a)
(make-response
: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
(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
:request r :data (funcall get-data a))))))
(sb-posix:syscall-error (c)
(make-response
: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)
(with-auth
@ -620,7 +632,7 @@
(let ((cur (client-article *client*)))
(make-response :code 223
: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)
(extract-mid (fetch-article g name)))
@ -667,7 +679,7 @@
(fetch-headers g i)))))))))))
(defun xover-format-line (i hs)
(str:concat (format nil "~a~a" i #\tab)
(str:concat (fmt "~a~a" i #\tab)
(str:join #\tab
(mapcar #'(lambda (h) (get-header h hs))
(xover-headers)))))
@ -682,7 +694,7 @@
(with-group g r
(set-group! 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)
(make-response :code 211 :request r :data ln))))))))
@ -708,7 +720,7 @@
(reverse
(mapcar
#'(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)))
(defun build-groups-structs ()
@ -827,7 +839,7 @@
(defun display-fn (cmd-pair)
(let ((cmd (cdr cmd-pair)))
(format nil "~A ~A"
(fmt "~A ~A"
(command-verb cmd)
(command-description cmd))))
@ -840,18 +852,29 @@
:data
(format-timestring nil (now))))
(defun conforms? (bs)
(catch 'article-syntax-error ;; parse-headers might throw
(let ((headers (parse-headers (article-headers (parse-article bs)))))
(let ((result (dolist (h (headers-required-from-clients))
(when (not (lookup h headers))
(return (format nil "missing the /~a/ header" h)))))
(content-type (get-header "content-type" headers)))
(cond
((stringp result) (values nil result))
((not (text/plain? content-type))
(values nil (format nil "content-type must be plain/text, but it's ~a" content-type)))
(t (values t nil)))))))
(defun conforms? (parsed-article)
(catch 'article-syntax-error ;; parse-header might throw
(let* ((headers (article-headers parsed-article))
(required (dolist (h (headers-required-from-clients))
(when (not (lookup h headers))
(return (fmt "missing the /~a/ header" h)))))
(content-type (get-header "content-type" headers))
(ngs-dont-exist
(let ((ls)
(ngs (article-newsgroups parsed-article)))
(dolist (g ngs)
(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)
;; I say T when S begins with "text/plain" or when S is "".
@ -866,7 +889,7 @@
'("from" "newsgroups" "subject"))
(defun suggest-message-id (&optional (n 20))
(format nil "<~a@loop>" (random-string n)))
(fmt "<~a@loop>" (random-string n)))
(defun random-string (size)
(let* ((universe "abcdefghijklmnopqrstuvwxyz")
@ -878,80 +901,69 @@
(coerce mid 'string)))
(defun unparse-article (parsed)
(data
(let ((ls))
(dolist (h (parse-headers (article-headers parsed)))
(setq ls (cons (data (str:capitalize (car h)) ": " (cdr h) (crlf)) ls)))
(nreverse ls))
(crlf)
(article-body parsed)))
(coerce
(data
(let ((ls))
(dolist (h (parse-head (article-head parsed)))
(setq ls (cons (data (str:capitalize (car h)) ": " (cdr h) (crlf)) ls)))
(nreverse ls))
(crlf)
(article-body parsed))
'vector))
(defun ensure-header (h fn bs)
(let* ((headers (parse-headers (article-headers (parse-article bs)))))
(if (lookup h headers)
bs
(unparse-article
(make-article
:headers
(str:join (crlf-string)
(mapcar #'(lambda (h)
(format nil "~a: ~a" (car h) (cdr h)))
(cons (cons h (funcall fn)) headers)))
:body (article-body (parse-article bs)))))))
(defun enrich-article (parsed-article)
(ensure-mid (ensure-date parsed-article)))
(defun ensure-mid (parsed-article)
(ensure-header "message-id" #'suggest-message-id parsed-article))
(defun ensure-date (parsed-article)
(ensure-header "date" #'get-date parsed-article))
(defun ensure-header (header fn-add-header parsed-article)
(if (lookup header (article-headers parsed-article))
parsed-article
(progn
(setf (article-headers parsed-article)
(cons (cons header (funcall fn-add-header))
(article-headers parsed-article)))
parsed-article)))
(defun get-date ()
(multiple-value-bind (s m h day mon year dow dst-p tz)
(get-decoded-time)
(declare (ignore dow dst-p))
(format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d GMT~a"
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))
(fmt "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d GMT~a"
year mon day h m s (- tz))))
(defun cmd-post (r)
(with-auth
(send-response!
(make-response
:code 340
:data (format nil "Okay, go ahead. Suggested message-id ~a."
:data (fmt "Okay, go ahead. Suggested message-id ~a."
(suggest-message-id))))
(let* ((bs (nntp-read-article)))
(multiple-value-bind (okay? error) (conforms? bs)
(let* ((bs (nntp-read-article))
(parsed-article (parse-article bs (client-username *client*))))
(multiple-value-bind (okay? error) (conforms? parsed-article)
(cond ((not okay?)
(make-response
:code 400 :request r
:data (format nil "Sorry. Your article doesn't conform: ~a." error)))
(t (multiple-value-bind (code reply) (post bs)
:data (fmt "Sorry. Your article doesn't conform: ~a." error)))
(t
(multiple-value-bind (code reply) (post (enrich-article parsed-article))
(make-response :code code :request r :data reply))))))))
(defun post (bs)
(let ((ngs (newsgroups-header->list
(get-header "newsgroups" (parse-headers
(article-headers
(parse-article bs))))))
(ngs-dont-exist))
(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 post (parsed-article)
(let* ((parsed-article (ensure-date (ensure-mid parsed-article)))
(bs (unparse-article parsed-article))
(ng (car (article-newsgroups parsed-article))))
(save-article-insist ng (get-next-article-id ng) bs)
(update-last-post-date! (client-username *client*)))
(defun newsgroups-header->list (s)
(mapcar #'(lambda (n) (str:trim (string-downcase n))) (str:split "," s)))
;; Now that we've saved the article, it's time to index it.
)
(defun update-last-post-date! (username)
(let ((u (get-account username)))
@ -961,8 +973,8 @@
(rename-file old (make-pathname :name new :type :unspecific)))
(defun save-article-try (name-try bs)
(let ((name (format nil "~a" name-try))
(tmp (format nil "~a.tmp" name-try)))
(let ((name (fmt "~a" name-try))
(tmp (fmt "~a.tmp" name-try)))
(with-open-file
(s name
:direction :output
@ -981,11 +993,11 @@
(write-sequence bs s))
(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
(in-dir (format nil "groups/~a/" g)
(when (not (eql 'name-exists (save-article-try name a)))
(return (values name (insert-index message-id g (fmt "~a" name))))))))
(in-dir (fmt "groups/~a/" g)
(when (not (eql 'name-exists (save-article-try name bs)))
(return name)))))
(defun get-next-article-id (g)
(multiple-value-bind (low high len) (group-high-low g)
@ -1020,7 +1032,7 @@
((stringp d) (string->bytes d))
((consp d) (list->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)
;; Add \r\n to each ``line''. Returns List-of Byte.
@ -1039,21 +1051,21 @@
(group-name-conforms? g)
(if (not okay?)
(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
(multiple-value-bind (path created?)
(in-groups (ensure-directories-exist (concatenate 'string g "/")))
(declare (ignore created?))
(if (not path)
(make-response :code 581 :request r
:data (format nil "could not create group ~a"
:data (fmt "could not create group ~a"
(if (group? g)
"because it already exists"
"but we don't know why---sorry!")))
(progn
(notify-group-created g)
(make-response :code 280 :request r
:data (format nil "group ~a created" g)))))))))))
:data (fmt "group ~a created" g)))))))))))
(defun group-name-conforms? (g)
(conforms-to? g "^[^\\s/]+$"))
@ -1114,7 +1126,7 @@
(defun write-accounts! ()
(let ((name
(let* ((tmp (random-string 10))
(name (format nil "~a.tmp" tmp)))
(name (fmt "~a.tmp" tmp)))
(with-open-file
(s name
:direction :output
@ -1124,7 +1136,7 @@
name))))
(rename-file name "accounts.lisp")
(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)
@ -1259,8 +1271,9 @@
(if u (let ((s (account-seen u)))
(if s (universal-to-human s))))))
(defun cmd-dd (r)
(make-response :code 200 :data (format nil "state: ~a" *client*) :request r))
(defun cmd-test (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)
(if *enable-nntp-repl*
@ -1291,14 +1304,14 @@
(in-groups (ensure-directories-exist "local.control.news/"))
(when (group? "local.control.news")
(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)
(make-article
:headers (data
(add-crlf-between
(mapcar
#'(lambda (p) (data (format nil "~a: ~a" (car p) (cdr p))))
#'(lambda (p) (data (fmt "~a: ~a" (car p) (cdr p))))
`(("from" . "Loop")
("subject" . ,subject)
("newsgroups" . "local.control.news")))))
@ -1308,7 +1321,7 @@
(clingon:make-command
:name "LOOP"
:description "An NNTP server for a circle of friends."
:version "a89e088"
:version "ec13a0c"
:options (root/options)
:handler #'root/handlers
:sub-commands (list (account/command))))
@ -1333,25 +1346,29 @@
:key :logging)))
(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))))
(root/main 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)))
(server-start)
;; (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
@ -1490,14 +1507,16 @@
(defun main ()
(read-accounts!)
(create-index!)
(let ((app (root/command)))
(clingon:run app)))
(server-start)
;; (let ((app (root/command)))
;; (clingon:run app))
)
(defun send-banner! ()
(send-response!
(make-response
: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)
(define-test dispatching
(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"))
#S(RESPONSE
:CODE 400
:DATA "unrecognized command"
:DATA "Unrecognized command."
:REQUEST #S(REQUEST :VERB "HELP" :ARGS NIL :SAID NIL)
:MULTI-LINE NIL)
\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")
("PASSWD" ,#'cmd-passwd "changes your password")
("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")
("DATE" ,#'cmd-date "displays the current date at this server")
("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)
(make-response
:code 400
:data "unrecognized command"
:data "Unrecognized command."
:request r))
:verb 'unrecognized
:description "a command for all commands typed wrong")))
@ -554,7 +554,7 @@ Here's how to send a [[response]] to a client.
(append seq
(when (not (= (car (last seq)) 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)
(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 ()
(read-accounts!)
(create-index!)
(let ((app (root/command)))
(clingon:run app)))
(server-start)
;; (let ((app (root/command)))
;; (clingon:run app))
)
(defun send-banner! ()
(send-response!
@ -661,7 +663,7 @@ An NNTP server for a circle of friends.
@
<<Version>>=
a89e088
ec13a0c
@
\section{Parsing of requests}
@ -741,14 +743,16 @@ In the root command, there's also a list of subcommands.
:key :logging)))
(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))))
(root/main 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
@ -806,15 +810,17 @@ have a certain main procedure. So this is it for the root command.
<<Command-line parsing>>=
(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)))
(server-start)
;; (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.
@ -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
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
set of all headers of an article, we can ask [[parse-headers]]. Yes,
I should've called the member [[headers]] as [[head]] and not
[[headers]] because both the word ``headers'' and its plural used here
suggest a list of parsed headers. We're going to rename this in due
time. %% TODO
set of all headers of an article, we can ask [[parse-head]]. All
other members of [[article]] are information needed in other places
such as [[post]].
<<Representation of articles>>=
(defstruct article headers body)
(defstruct article message-id newsgroups headers username body head)
@
<<How to parse articles>>=
(defun parse-article (v)
(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))))
(defun parse-article (v &optional (username nil))
(let* ((parts (split-vector (vector 13 10 13 10) v nil :limit 2))
(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)
(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))
@ -1011,28 +1027,26 @@ time. %% TODO
(let* ((h (str:collapse-whitespaces header))
(pos (search ":" h)))
(when (null pos)
(throw 'article-syntax-error
(values nil (format nil "missing colon in header |~a|" h))))
(throw 'article-syntax-error (values nil (fmt "missing colon in header |~a|" h))))
(when (<= (length h) (+ 2 pos))
(throw 'article-syntax-error
(values nil (format nil "empty header ~a" h))))
(throw 'article-syntax-error (values nil (fmt "empty header ~a" h))))
(multiple-value-bind (key val)
(values (subseq h 0 pos) (subseq h (+ 2 pos)))
(cons (str:downcase key) val))))
(defun parse-headers (hs)
(defun parse-head (hs)
(let ((ls (hs-lines (hs-space-collapsed hs))))
(mapcar #'(lambda (h) (parse-header h)) ls)))
(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
overview} of the command \verb|XOVER|.
<<How to parse articles>>=
(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)
(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)
(let* ((a-string (fetch-article g i))
(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)))
(defun enrich-headers (hs a)
(append hs
`(("line-count" . ,(format nil "~a" (nlines (article-body (parse-article a)))))
("byte-count" . ,(format nil "~a" (length a))))))
`(("line-count" . ,(fmt "~a" (nlines (article-body (parse-article a)))))
("byte-count" . ,(fmt "~a" (length a))))))
(defun nlines (v) (length (split-vector (crlf) v nil)))
@ %def get-header fetch-headers
@ -1062,7 +1076,7 @@ interpreting such bytes. That's why we call [[read-sequence]] here.
<<How to parse articles>>=
(defun fetch-article (g i)
(in-groups
(read-file-raw (format nil "~a/~a" g i))))
(read-file-raw (fmt "~a/~a" g i))))
(defun read-file-raw (path)
(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
this section. Notice that I also wrote [[mid-by-name]], which should
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
<<How to parse articles>>=
(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)
(cdr (assoc key table :test #'string=)))
@ %def extract-mid lookup
@ -1133,7 +1147,7 @@ reason to think we're doing to debug it.}
(defun display-fn (cmd-pair)
(let ((cmd (cdr cmd-pair)))
(format nil "~A ~A"
(fmt "~A ~A"
(command-verb cmd)
(command-description cmd))))
@
@ -1165,7 +1179,7 @@ Syntax error. Say ``authinfo USER /your-name/'' then ``authinfo PASS /your-pass/
((string= cmd "USER")
(setf (client-username *client*) arg)
(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")
(if (authinfo-check (client-username *client*) arg)
(progn
@ -1288,7 +1302,7 @@ from there to see what's happening. Not easy.
(defun write-accounts! ()
(let ((name
(let* ((tmp (random-string 10))
(name (format nil "~a.tmp" tmp)))
(name (fmt "~a.tmp" tmp)))
(with-open-file
(s name
:direction :output
@ -1298,7 +1312,7 @@ from there to see what's happening. Not easy.
name))))
(rename-file name "accounts.lisp")
(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)
@ -1490,7 +1504,7 @@ even cache the overview of the group.) %% TODO
(reverse
(mapcar
#'(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)))
(defun build-groups-structs ()
@ -1631,7 +1645,7 @@ We just need to verify if the group exists and modify [[*client*]].
(with-group g r
(set-group! 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)
(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)
(if (and 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.")))))))
(defun cmd-head (r)
@ -1689,7 +1703,7 @@ Section~\ref{sec:index} for the implementation of the index.
(defun article-response (r g i)
(typical-cmd-response 220 r g i #'(lambda (a) (encode-body a))))
(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)
(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)
(make-response
: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
(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
:request r :data (funcall get-data a))))))
(sb-posix:syscall-error (c)
(make-response
: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
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*)))
(make-response :code 223
: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)
(extract-mid (fetch-article g name)))
@ -1812,7 +1826,7 @@ to the last one.
:test #'string=))
(fetch-headers g i)))))))))))
(defun xover-format-line (i hs)
(str:concat (format nil "~a~a" i #\tab)
(str:concat (fmt "~a~a" i #\tab)
(str:join #\tab
(mapcar #'(lambda (h) (get-header h hs))
(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'm going to remove this very soon.
<<Command dd>>=
(defun cmd-dd (r)
(make-response :code 200 :data (format nil "state: ~a" *client*) :request r))
<<Command test>>=
(defun cmd-test (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
\subsection{{\tt POST}}\label{sec:post}
@ -1877,7 +1892,7 @@ must have \verb|message-id|, \verb|subject|, \verb|from|,
<<Command post>>=
<<Does an article conform?>>
(defun suggest-message-id (&optional (n 20))
(format nil "<~a@loop>" (random-string n)))
(fmt "<~a@loop>" (random-string n)))
(defun random-string (size)
(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
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>>=
(defun unparse-article (parsed)
(data
(let ((ls))
(dolist (h (parse-headers (article-headers parsed)))
(setq ls (cons (data (str:capitalize (car h)) ": " (cdr h) (crlf)) ls)))
(nreverse ls))
(crlf)
(article-body parsed)))
(coerce
(data
(let ((ls))
(dolist (h (parse-head (article-head parsed)))
(setq ls (cons (data (str:capitalize (car h)) ": " (cdr h) (crlf)) ls)))
(nreverse ls))
(crlf)
(article-body parsed))
'vector))
@ %def unparse-article
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.
<<Command post>>=
(defun ensure-header (h fn bs)
(let* ((headers (parse-headers (article-headers (parse-article bs)))))
(if (lookup h headers)
bs
(unparse-article
(make-article
:headers
(str:join (crlf-string)
(mapcar #'(lambda (h)
(format nil "~a: ~a" (car h) (cdr h)))
(cons (cons h (funcall fn)) headers)))
:body (article-body (parse-article bs)))))))
(defun enrich-article (parsed-article)
(ensure-mid (ensure-date parsed-article)))
(defun ensure-mid (parsed-article)
(ensure-header "message-id" #'suggest-message-id parsed-article))
(defun ensure-date (parsed-article)
(ensure-header "date" #'get-date parsed-article))
(defun ensure-header (header fn-add-header parsed-article)
(if (lookup header (article-headers parsed-article))
parsed-article
(progn
(setf (article-headers parsed-article)
(cons (cons header (funcall fn-add-header))
(article-headers parsed-article)))
parsed-article)))
(defun get-date ()
(multiple-value-bind (s m h day mon year dow dst-p tz)
(get-decoded-time)
(declare (ignore dow dst-p))
(format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d GMT~a"
year mon day h m s (- tz))))
(fmt "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d GMT~a"
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
Now it's time to look at the header \verb|newsgroups|. XXX: we need
to rewrite this because we have that plan of verifying everything
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
Now it's time to look at the header \verb|newsgroups|. We can begin
with the name of each group must conform to the expression...
<<Form of newsgroup names>>=
^[^\\s/]+$
@ -1965,15 +1989,17 @@ of trying to stop them.
(send-response!
(make-response
:code 340
:data (format nil "Okay, go ahead. Suggested message-id ~a."
:data (fmt "Okay, go ahead. Suggested message-id ~a."
(suggest-message-id))))
(let* ((bs (nntp-read-article)))
(multiple-value-bind (okay? error) (conforms? bs)
(let* ((bs (nntp-read-article))
(parsed-article (parse-article bs (client-username *client*))))
(multiple-value-bind (okay? error) (conforms? parsed-article)
(cond ((not okay?)
(make-response
:code 400 :request r
:data (format nil "Sorry. Your article doesn't conform: ~a." error)))
(t (multiple-value-bind (code reply) (post bs)
:data (fmt "Sorry. Your article doesn't conform: ~a." error)))
(t
(multiple-value-bind (code reply) (post (enrich-article parsed-article))
(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.
<<Command post>>=
(defun post (bs)
(let ((ngs (newsgroups-header->list
(get-header "newsgroups" (parse-headers
(article-headers
(parse-article bs))))))
(ngs-dont-exist))
(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 post (parsed-article)
(let* ((parsed-article (ensure-date (ensure-mid parsed-article)))
(bs (unparse-article parsed-article))
(ng (car (article-newsgroups parsed-article))))
(save-article-insist ng (get-next-article-id ng) bs)
(update-last-post-date! (client-username *client*)))
(defun newsgroups-header->list (s)
(mapcar #'(lambda (n) (str:trim (string-downcase n))) (str:split "," s)))
;; Now that we've saved the article, it's time to index it.
)
@ %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>>=
(defun update-last-post-date! (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)))
(defun save-article-try (name-try bs)
(let ((name (format nil "~a" name-try))
(tmp (format nil "~a.tmp" name-try)))
(let ((name (fmt "~a" name-try))
(tmp (fmt "~a.tmp" name-try)))
(with-open-file
(s name
:direction :output
@ -2080,11 +2082,11 @@ allocated. Notice that the argument [[name]] is an integer, so
[[name]] is incremented at each iteration.
<<Command post>>=
(defun save-article-insist (g name a message-id)
(defun save-article-insist (g name bytes)
(loop for name from name do
(in-dir (format nil "groups/~a/" g)
(when (not (eql 'name-exists (save-article-try name a)))
(return (values name (insert-index message-id g (fmt "~a" name))))))))
(in-dir (fmt "groups/~a/" g)
(when (not (eql 'name-exists (save-article-try name bs)))
(return name)))))
(defun get-next-article-id (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))
((consp d) (list->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)
;; 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
itself.
Let's criticize the writing of [[conforms?]]. We have a [[catch]]
here and a [[throw]] in [[parse-headers]]. We also have a [[return]]
here. It's getting hard to read this procedure because it's not easy
to know that a procedure has to return a certain value to match the
expectation of another procedure. I don't remember what [[catch]]
does. I need to review this and then add the explanation for myself.
If I don't remember how this works, other beginners won't know it
either. %% TODO
The way we're writing [[conforms?]], and the way to read it, is we do
a bunch of checks in the [[let*]] form, all the checks we want to do.
Then in the [[cond]], we react to the results. This strategy allows
us to report all problems found, not just the first, but I believe we
should not report too much to the client: these reports are usually
presented in a alert-like pop-up window with an okay button. But we
could report everything.
<<Does an article conform?>>=
(defun conforms? (bs)
(catch 'article-syntax-error ;; parse-headers might throw
(let ((headers (parse-headers (article-headers (parse-article bs)))))
(let ((result (dolist (h (headers-required-from-clients))
(when (not (lookup h headers))
(return (format nil "missing the /~a/ header" h)))))
(content-type (get-header "content-type" headers)))
(cond
((stringp result) (values nil result))
((not (text/plain? content-type))
(values nil (format nil "content-type must be plain/text, but it's ~a" content-type)))
(t (values t nil)))))))
(defun conforms? (parsed-article)
(catch 'article-syntax-error ;; parse-header might throw
(let* ((headers (article-headers parsed-article))
(required (dolist (h (headers-required-from-clients))
(when (not (lookup h headers))
(return (fmt "missing the /~a/ header" h)))))
(content-type (get-header "content-type" headers))
(ngs-dont-exist
(let ((ls)
(ngs (article-newsgroups parsed-article)))
(dolist (g ngs)
(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)
;; I say T when S begins with "text/plain" or when S is "".
(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
influence to the article storage. For instance, \verb|newsgroups|
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;
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
check each group.
\subsection{{\tt CREATE-GROUP}}
@ -2237,21 +2247,21 @@ all or it has been discussed with the community beforehand.
(group-name-conforms? g)
(if (not okay?)
(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
(multiple-value-bind (path created?)
(in-groups (ensure-directories-exist (concatenate 'string g "/")))
(declare (ignore created?))
(if (not path)
(make-response :code 581 :request r
:data (format nil "could not create group ~a"
:data (fmt "could not create group ~a"
(if (group? g)
"because it already exists"
"but we don't know why---sorry!")))
(progn
(notify-group-created g)
(make-response :code 280 :request r
:data (format nil "group ~a created" g)))))))))))
:data (fmt "group ~a created" g)))))))))))
(defun group-name-conforms? (g)
(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/"))
(when (group? "local.control.news")
(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)
(make-article
:headers (data
(add-crlf-between
(mapcar
#'(lambda (p) (data (format nil "~a: ~a" (car p) (cdr p))))
#'(lambda (p) (data (fmt "~a: ~a" (car p) (cdr p))))
`(("from" . "Loop")
("subject" . ,subject)
("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)
(let ((from (fmt "index/~a" m))
(to (fmt "../groups/~a/~a" g i)))
(stderr "Creating link from ~a to ~a...~%" from to)
(create-symbolic-link from to)))
@ %def insert-index.
@ -2748,7 +2759,7 @@ any more.
(,r-var ,r))
(if (not (group? ,g-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)))))
(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))
(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)
(dolist (a args) (princ a s))))
(defun data (&rest args) ;; a utility
(defun data (&rest args)
(flatten (map 'list #'data->bytes args)))
(defun crlf ()
(vector 13 10))
(defun crlf-string ()
(format nil "~c~c" #\return #\linefeed))
(fmt "~c~c" #\return #\linefeed))
(defun flatten (obj)
(do* ((result (list obj))
@ -3022,7 +3033,8 @@ something to think about.
(:use :common-lisp :local-time)
(:import-from :lisp-unit define-test assert-true)
(: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)
(:export :main))
@ -3058,7 +3070,7 @@ something to think about.
<<Command login>>
<<Command passwd>>
<<Command users>>
<<Command dd>>
<<Command test>>
<<Command repl>>
<<Broadcasting>>
<<Command-line parsing>>
@ -3168,12 +3180,23 @@ usage()
test $# -lt 2 && usage
tag="$1"; shift
sed "/<<Version>>=/ {
n;
sed "/@<<Version@>>=/ {
n
c\\
$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}
\nowebchunks

4
make-release
View file

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