-
Notifications
You must be signed in to change notification settings - Fork 160
/
news.arc
1774 lines (1414 loc) · 56.1 KB
/
news.arc
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
; News. 2 Sep 06.
; to run news:
; arc> (load "news.arc")
; arc> (nsv)
; put usernames of admins, separated by whitespace, in arc/admins
(= this-site* "My Forum"
site-url* "http://news.yourdomain.com/"
parent-url* "http://www.yourdomain.com"
favicon-url* ""
site-desc* "What this site is about." ; for rss feed
site-color* orange
prefer-url* t)
(= rootdir* "arc/news_public_html/")
; Structures
; Could add (html) types like choice, yesno to profile fields. But not
; as part of deftem, which is defstruct. Need another mac on top of
; deftem. Should not need the type specs in user-fields.
(deftem profile
id nil
name nil
created (seconds)
auth 0
member nil
submitted nil
karma 1
weight .5
ignore nil
nodowns nil
email nil
about nil
showdead nil
noprocrast nil
firstview nil
lastview nil
maxvisit 20
minaway 180
topcolor nil
keys nil)
(deftem item
id nil
type nil
by nil
ip nil
time (seconds)
url nil
title nil
text nil
votes nil ; elts each (time ip user type score)
score 0
sockvotes 0
dead nil
deleted nil
parent nil
kids nil)
; Load and Save
(= newsdir* "arc/news/"
storydir* "arc/news/story/"
profdir* "arc/news/profile/"
votedir* "arc/news/vote/")
(= votes* (table) profs* (table))
(def nsv ((o port 8080))
(map ensure-dir (list arcdir* newsdir* storydir* votedir* profdir*))
(unless stories* (load-items))
(if (empty profs*) (load-users))
(asv port))
(def load-users ()
(pr "load users: ")
(noisy-each 100 id (dir profdir*)
(load-user id)))
(def load-user (u)
(= (votes* u) (load-table (+ votedir* u))
(profs* u) (temload 'profile (+ profdir* u)))
u)
(def init-user (u)
(= (votes* u) (table) (profs* u) (inst 'profile 'id u))
(save-votes u)
(save-prof u)
u)
; Need this because can create users on the server (for other apps)
; without setting up places to store their state as news users.
; See the admin op in app.arc. So all calls to login-page from the
; news app need to call this in the after-login fn.
(def ensure-news-user (u)
(if (profs* u) u (init-user u)))
(def save-votes (u) (save-table (votes* u) (+ votedir* u)))
(def save-prof (u) (save-table (profs* u) (+ profdir* u)))
(mac uvar (u k) `((profs* ,u) ',k))
(mac karma (u) `(uvar ,u karma))
(def users (f) (keep f (keys profs*)))
(= stories* nil comments* nil items* (table) url->story* (table)
maxid* 0 initload* 15000)
; The dir expression yields stories in order of file creation time
; (because arc infile truncates), so could just rev the list instead of
; sorting, but sort anyway.
; Note that stories* etc only include the initloaded (i.e. recent)
; ones, plus those created since this server process started.
; Could be smarter about preloading by keeping track of most popular pages.
(def load-items ()
(pr "load items: ")
(with (items (table)
ids (sort > (map [coerce _ 'int] (dir storydir*))))
(if ids (= maxid* (car ids)))
(noisy-each 100 id (firstn initload* ids)
(let i (load-item id)
(push i (items i!type))))
(= stories* (rev items!story) comments* (rev items!comment))
(hook 'initload items))
(ensure-topstories))
(def ensure-topstories ()
(aif (errsafe (readfile1 (+ newsdir* "topstories")))
(= ranked-stories* (map item it))
(do (prn "ranking stories.")
(gen-topstories))))
(def astory (i) (is i!type 'story))
(def acomment (i) (is i!type 'comment))
(def load-item (id)
(let i (temload 'item (string storydir* id))
(= (items* id) i (i 'id) id)
(awhen (and (astory i) (live i) i!url)
(= (url->story* it) i))
i))
(def new-item-id ()
(let id (++ maxid*)
(if (file-exists (string storydir* id)) (new-item-id) id)))
(def item (id)
(or (items* id) (errsafe (load-item id))))
(def kids (x) (map item x!kids))
; For use on external item references (from urls).
; Checks id is int because people try e.g. item?id=363/blank.php
(def safe-item (id)
(let id (if (isa id 'string) (saferead id) id)
(and (ok-id id) (item id))))
(def ok-id (id)
(and (exact id) (<= 1 id maxid*)))
(def arg->item (req key)
(safe-item:saferead (arg req key)))
(def live (i) (nor i!dead i!deleted))
(def live-child (d) (find live (kids d)))
(def save-item (i) (save-table i (string storydir* i!id)))
(def kill (i)
(assert i!dead)
(save-item i))
(def newslog args (apply srvlog 'news args))
; Ranking
; Votes divided by the age in hours to the gravityth power.
; Would be interesting to scale gravity in a slider.
(= gravity* 1.4 timebase* 120 front-threshold* 1)
(def frontpage-rank (s (o gravity gravity*))
(/ (- (realscore s) 1)
(expt (/ (+ (item-age s) timebase*) 60) gravity)))
(def realscore (i) (- i!score i!sockvotes))
(def item-age (i) (minutes-since i!time))
(def user-age (u) (minutes-since (uvar u created)))
; Only looks at the 1000 most recent stories, which might one day be a
; problem if there is massive spam.
(def gen-topstories ()
(= ranked-stories* (rank-stories 180 1000 (memo frontpage-rank))))
(def save-topstories ()
(writefile1 (map [_ 'id] (firstn 180 ranked-stories*))
(+ newsdir* "topstories")))
(def rank-stories (n consider scorefn)
(bestn n (compare > scorefn) (recent-stories consider)))
; The n most recent stories. Use firstn when add virtual lists.
(def recent-stories (n (o id maxid*) (o acc nil))
(if (or (< n 1) (< id 1))
(rev acc)
(let s (item id)
(if (storylike s)
(recent-stories (- n 1) (- id 1) (cons s acc))
(recent-stories n (- id 1) acc)))))
(def storylike (i) (and i (astory i)))
(def adjust-rank (s (o scorefn frontpage-rank))
(insortnew (compare > (memo scorefn)) s ranked-stories*)
(save-topstories))
; If something rose high then stopped getting votes, its score would
; decline but it would stay near the top. Newly inserted stories would
; thus get stuck in front of it. I avoid this by regularly adjusting
; the rank of a random top story.
(def rerank-random ((o depth 15))
(when ranked-stories*
(adjust-rank (ranked-stories* (rand (min depth (len ranked-stories*))))))
(save-topstories))
(def topstories (user n (o threshold front-threshold*))
(firstn-that n
[and (>= (realscore _) threshold) (cansee user _)]
ranked-stories*))
; If had ip of current request could add clause below to make ignore
; tighter better, but wait till need to.
(def cansee (user i)
(if i!deleted (admin user)
i!dead (or (is user i!by) (seesdead user))
; ip of this request is i!ip
t))
(def seesdead (user)
(or (and user (uvar user showdead) (no (uvar user ignore)))
(editor user)))
(def visible (user is)
(keep [cansee user _] is))
(def cansee-descendant (user c)
(or (cansee user c)
(some [cansee-descendant user (item _)]
c!kids)))
(def editor (u)
(and u (or (admin u) (> (uvar u auth) 0))))
(def member (u)
(and u (or (admin u) (uvar u member))))
; Page Layout
(= up-url* "grayarrow.gif" down-url* "graydown.gif" logo-url* "y18.gif")
(defopr favicon.ico req favicon-url*)
(mac npage (title . body)
`(tag html
(tag head
(prn "<link rel=\"stylesheet\" type=\"text/css\" href=\"news.css\">")
(prn "<link rel=\"shortcut icon\" href=\"" favicon-url* "\">")
(tag script (pr votejs*))
(tag title (pr ,title)))
(tag body
(center
(tag (table border 0 cellpadding 0 cellspacing 0 width "85%"
bgcolor sand)
,@body)))))
(= pagefns* nil)
(mac fulltop (user label title whence . body)
(w/uniq (gu gl gt gw)
`(with (,gu ,user ,gl ,label ,gt ,title ,gw ,whence)
(npage (+ this-site* (if ,gt (+ bar* ,gt) ""))
(if (check-procrast ,gu)
(do (pagetop 'full ,gl ,gt ,gu ,gw)
(hook 'page ,gu ,gl)
,@body)
(row (procrast-msg ,gu ,gw)))))))
(mac longpage (user t1 label title whence . body)
(w/uniq (gu gt)
`(with (,gu ,user ,gt ,t1)
(fulltop ,gu ,label ,title ,whence
(trtd ,@body)
(trtd (vspace 10)
(color-stripe (main-color ,gu))
(br)
(center
(hook 'longfoot)
(admin-bar ,gu (- (msec) ,gt) ,whence)))))))
(def admin-bar (user elapsed whence)
(when (admin user)
(br2)
(w/bars
(pr (len items*) "/" maxid* " loaded")
(pr elapsed " msec")
(link "settings" "newsadmin")
(hook 'admin-bar user whence))))
(def color-stripe (c)
(tag (table width "100%" cellspacing 0 cellpadding 1)
(tr (tdcolor c))))
(mac shortpage (user label title whence . body)
`(fulltop ,user ,label ,title ,whence
(trtd ,@body)))
(mac minipage (label . body)
`(npage (+ this-site* bar* ,label)
(pagetop nil ,label)
(trtd ,@body)))
; remember to (= caching* 0) or won't see changes
(defop news.css req
(pr "
body { font-family:Verdana; font-size:10pt; color:#828282; }
td { font-family:Verdana; font-size:10pt; color:#828282; }
.admin td { font-family:Verdana; font-size:8.5pt; color:#000000; }
.subtext td { font-family:Verdana; font-size: 7pt; color:#828282; }
input { font-family:Courier; font-size:10pt; color:#000000; }
input[type=\"submit\"] { font-family:Verdana; }
textarea { font-family:Courier; font-size:10pt; color:#000000; }
a:link { color:#000000; text-decoration:none; }
a:visited { color:#828282; text-decoration:none; }
.default { font-family:Verdana; font-size: 10pt; color:#828282; }
.admin { font-family:Verdana; font-size:8.5pt; color:#000000; }
.title { font-family:Verdana; font-size: 10pt; color:#828282; }
.adtitle { font-family:Verdana; font-size: 9pt; color:#828282; }
.subtext { font-family:Verdana; font-size: 7pt; color:#828282; }
.yclinks { font-family:Verdana; font-size: 8pt; color:#828282; }
.pagetop { font-family:Verdana; font-size: 10pt; color:#222222; }
.comhead { font-family:Verdana; font-size: 8pt; color:#828282; }
.comment { font-family:Verdana; font-size: 9pt; }
.dead { font-family:Verdana; font-size: 9pt; color:#dddddd; }
.comment a:link, .comment a:visited { text-decoration:underline;}
.dead a:link, .dead a:visited { color:#dddddd; }
.pagetop a:visited { color:#000000;}
.topsel a:link, .topsel a:visited { color:#ffffff; }
.subtext a:link, .subtext a:visited { color:#828282; }
.subtext a:hover { text-decoration:underline; }
.comhead a:link, .subtext a:visited { color:#828282; }
.comhead a:hover { text-decoration:underline; }
.default p { margin-top: 8px; margin-bottom: 0px; }
.pagebreak {page-break-before:always}
pre { overflow: hidden; padding: 2px; }
pre:hover {overflow:auto} "))
; only need pre padding because of a bug in Mac Firefox
; Without setting the bottom margin of p tags to 0, 1- and n-para comments
; have different space at the bottom. This solution suggested by Devin.
; Really am using p tags wrong (as separators rather than wrappers) and the
; correct thing to do would be to wrap each para in <p></p>. Then whatever
; I set the bottom spacing to, it would be the same no matter how many paras
; in a comment. In this case by setting the bottom spacing of p to 0, I'm
; making it the same as no p, which is what the first para has.
; supplied by pb
;.vote { padding-left:2px; vertical-align:top; }
;.comment { margin-top:1ex; margin-bottom:1ex; color:black; }
;.vote IMG { border:0; margin: 3px 2px 3px 2px; }
;.reply { font-size:smaller; text-decoration:underline !important; }
(= votejs* "
function byId(id) {
return document.getElementById(id);
}
function vote(node) {
var v = node.id.split(/_/); // {'up', '123'}
var item = v[1];
// adjust score
var score = byId('score_' + item);
var newscore = parseInt(score.innerHTML) + (v[0] == 'up' ? 1 : -1);
score.innerHTML = newscore + (newscore == 1 ? ' point' : ' points');
// hide arrows
byId('up_' + item).style.visibility = 'hidden';
byId('down_' + item).style.visibility = 'hidden';
// ping server
var ping = new Image();
ping.src = node.href;
return false; // cancel browser nav
} ")
; Page top
(= sand (color 246 246 239) textgray (gray 130))
(def main-color (user)
(aif (and user (uvar user topcolor))
(hex>color it)
site-color*))
(def pagetop (switch label (o title) (o user) (o whence))
(tr (tdcolor (main-color user)
(tag (table border 0 cellpadding 0 cellspacing 0 width "100%"
style "padding:2px")
(tr (gen-logo)
(when (is switch 'full)
(tag (td style "line-height:12pt; height:10px;")
(spanclass pagetop
(tag b (link this-site* "news"))
(hspace 10)
(toprow user label))))
(if (is switch 'full)
(tag (td style "text-align:right;padding-right:4px;")
(spanclass pagetop (topright user whence)))
(tag (td style "line-height:12pt; height:10px;")
(spanclass pagetop (prbold label))))))))
(map [_ user] pagefns*)
(spacerow 10))
(def gen-logo ()
(tag (td style "width:18px;padding-right:4px")
(tag (a href parent-url*)
(gentag img src logo-url* width 18 height 18
style "border:1px white solid;"))))
(= toplabels* '(nil "new" "threads" "comments" "leaders" "*"))
(def toprow (user label)
(w/bars
(toplink "new" "newest" label)
(when user
(toplink "threads" (threads-url user) label))
(toplink "comments" "newcomments" label)
(toplink "leaders" "leaders" label)
(hook 'toprow user label)
(link "submit")
(unless (mem label toplabels*)
(tag (font color white) (pr label)))))
(def toplink (name dest label)
(tag-if (is name label) (span class 'topsel)
(link name dest)))
(def topright (user whence (o showkarma t))
(when user
(link user (user-url user))
(when showkarma (pr " (" (karma user) ")"))
(pr " | "))
(if user
(rlinkf 'logout (req)
(when-umatch/r user req
(logout-user user)
whence))
(onlink "login"
(login-page 'both nil
(list (fn (u ip)
(ensure-news-user u)
(newslog u 'top-login ip))
whence)))))
; News-Specific Defop Variants
(mac defopt (name parm test msg . body)
`(defop ,name ,parm
(if (,test (get-user ,parm))
(do ,@body)
(login-page 'both (+ "Please log in" ,msg ".")
(list (fn (u ip) (ensure-news-user u))
(string ',name (reassemble-args ,parm)))))))
(mac defopg (name parm . body)
`(defopt ,name ,parm idfn "" ,@body))
(mac defope (name parm . body)
`(defopt ,name ,parm editor " as an editor" ,@body))
(mac defopa (name parm . body)
`(defopt ,name ,parm admin " as an administrator" ,@body))
(mac opexpand (definer name parms . body)
(w/uniq gr
`(,definer ,name ,gr
(with (user (get-user ,gr) ip (,gr 'ip))
(with ,(and parms (mappend [list _ (list 'arg gr (string _))]
parms))
(newslog user ',name ip ,@parms)
,@body)))))
(= newsop-names* nil)
(mac newsop args
`(do (pushnew ',(car args) newsop-names*)
(opexpand defop ,@args)))
(mac adop (name parms . body)
(w/uniq g
`(opexpand defopa ,name ,parms
(let ,g (string ',name)
(shortpage user ,g ,g ,g
,@body)))))
; News Admin
(defopa newsadmin req (newsadmin-page (get-user req)))
; For emergency, real-time changes. All are reset to the val in the
; source code when restart server.
(def nad-fields ()
`((num caching ,caching* t t)
(posint front-threshold ,front-threshold* t t)
(int legit-threshold ,legit-threshold* t t)
(bigtoks url-kill ,url-kill* t t)
(bigtoks url-ignore ,url-ignore* t t)
(bigtoks comment-kill ,comment-kill* t t)
(bigtoks comment-ignore ,comment-ignore* t t)
(bigtoks ip-ban ,ip-ban* t t)))
; Need a util like vars-form for a collection of variables.
; Or could generalize vars-form to think of places (in the setf sense).
(def newsadmin-page (user)
(newslog user 'newsadmin)
(shortpage user "newsadmin" "News Admin Page" "newsadmin"
(vars-form user (nad-fields)
(fn (name val)
(case name
caching (= caching* val)
front-threshold (= front-threshold* val)
legit-threshold (= legit-threshold* val)
url-kill (= url-kill* val)
url-ignore (= url-ignore* val)
comment-kill (= comment-kill* val)
comment-ignore (= comment-ignore* val)
ip-ban (= ip-ban* val)))
(fn () (newsadmin-page user)))
(br2)
(aform (fn (req)
(with (user (get-user req) subject (arg req "id"))
(if (profs* subject)
(do (killallby subject)
(submitted-page user subject))
(if (admin user) (newsadmin-page user)))))
(single-input "" 'id 20 "kill all by"))))
; Users
(newsop user (id)
(if (profs* id)
(user-page user id)
(pr "No such user.")))
(def user-page (user subject)
(let here (user-url subject)
(shortpage user nil (+ "Profile: " subject) here
(profile-form user subject)
(br2)
(when (some astory:item (uvar subject submitted))
(underlink "submissions" (submitted-url subject)))
(when (some acomment:item (uvar subject submitted))
(sp)
(underlink "comments" (threads-url subject)))
(hook 'user user subject))))
(def profile-form (user subject)
(let prof (profs* subject)
(vars-form user
(user-fields user subject)
(fn (name val) (= (prof name) val))
(fn () (save-prof subject)
(user-page user subject)))))
(= topcolor-threshold* 250)
(def user-fields (user subject)
(withs (e (editor user)
a (admin user)
w (is user subject)
k (and w (> (karma user) topcolor-threshold*))
u (or a w)
m (or a (and (member user) w))
p (profs* subject))
`((string user ,subject t nil)
(string name ,(p 'name) ,m ,m)
(string created ,(text-age:user-age subject) t nil)
(string password ,(resetpw-link) ,w nil)
(string saved ,(saved-link user subject) ,u nil)
(int auth ,(p 'auth) ,e ,a)
(yesno member ,(p 'member) ,a ,a)
(posint karma ,(p 'karma) t ,a)
(yesno ignore ,(p 'ignore) ,e ,e)
(num weight ,(p 'weight) ,a ,a)
(yesno nodowns ,(p 'nodowns) ,a ,a)
(mdtext about ,(p 'about) t ,u)
(string email ,(p 'email) ,u ,u)
(yesno showdead ,(p 'showdead) ,u ,u)
(yesno noprocrast ,(p 'noprocrast) ,u ,u)
(string firstview ,(p 'firstview) ,a nil)
(string lastview ,(p 'lastview) ,a nil)
(posint maxvisit ,(p 'maxvisit) ,u ,u)
(posint minaway ,(p 'minaway) ,u ,u)
(sexpr keys ,(p 'keys) ,a ,a)
(hexcol topcolor ,(or (p 'topcolor) (hexrep site-color*)) ,k ,k))))
(def saved-link (user subject)
(when (or (admin user) (is user subject))
(let n (len (voted-stories user subject))
(if (is n 0)
""
(tostring (underlink n (saved-url subject)))))))
(def resetpw-link ()
(tostring (underlink "reset password" "resetpw")))
; Main Operators
; remember to set caching to 0 when testing non-logged-in
(= caching* 0 perpage* 30 maxend* 200)
; Limiting that newscache can't take any arguments except the user.
; To allow other arguments, would have to turn the cache from a single
; stored value to a hash table whose keys were lists of arguments.
(mac newscache (name user time . body)
(w/uniq gc
`(let ,gc (cache (fn () (* caching* ,time))
(fn () (tostring (let ,user nil ,@body))))
(def ,name (,user)
(if ,user
(do ,@body)
(pr (,gc)))))))
(newsop news () (newspage user))
(newsop || () (newspage user))
;(newsop index.html () (newspage user))
(newscache newspage user 90
(rerank-random)
(listpage user (msec) (topstories user maxend*) nil nil "news" t))
(def listpage (user t1 items label title (o url label) (o number))
(hook 'listpage user)
(longpage user t1 label title url
(display-items user items label title url 0 perpage* number)))
(newsop newest () (newestpage user))
; Note: dead/deleted items will persist for the remaining life of the
; cached page. If this were a prob, could make deletion clear caches.
(newscache newestpage user 40
(rerank-random)
(listpage user (msec) (newstories user maxend*) "new" "New Links" "newest" t))
(def newstories (user n)
(firstn-that n [cansee user _] stories*))
(newsop best () (bestpage user))
(newscache bestpage user 1000
(listpage user (msec) (beststories user maxend*) "best" "Top Links" "best" t))
; As no of stories gets huge, could test visibility in fn sent to best.
(def beststories (user n)
(bestn n (compare > realscore) (visible user stories*)))
(newsop bestcomments () (bestcpage user))
(newscache bestcpage user 1000
(listpage user (msec) (bestcomments user maxend*)
"best comments" "Best Comments" "bestcomments"))
(def bestcomments (user n)
(bestn n (compare > realscore) (visible user comments*)))
(newsop lists ()
(longpage user (msec) "lists" "Lists" "lists"
(tag table
(row "" (hspace 10))
(row (link "best") "" "Highest voted recent links.")
(row (link "active") "" "Most active current discussions.")
(row (link "bestcomments") "" "Highest voted recent comments.")
(when (admin user)
(map [row (link _)]
'(optimes killed badguys badlogins goodlogins)))
(hook 'listspage user))))
(def saved-url (user) (string "saved?id=" user))
(newsop saved (id)
(if (profs* id)
(savedpage user id)
(pr "No such user.")))
(def savedpage (user subject)
(if (or (is user subject) (admin user))
(listpage user (msec)
(sort (compare < item-age) (voted-stories user subject))
"saved" "Saved Links" (saved-url subject) t)
(pr "Can't display that.")))
(def voted-stories (user subject)
(keep [and (astory _) (cansee user _)]
(map item (keys:votes* subject))))
; Story Display
(def display-items (user items label title whence
(o start 0) (o end perpage*) (o number))
(zerotable
(let n start
(each i (if end (cut items start end) items)
(display-item (and number (++ n)) i user whence t)
(spacerow (if (acomment i) 15 5))))
(when end
(let newend (+ end perpage*)
(when (and (<= newend maxend*) (< end (len items)))
(spacerow 10)
(tr (tag (td colspan (if number 2 1)))
(tag (td class 'title)
(morelink items label title end newend number))))))))
; This code is inevitably complex because the More fn needs to know
; its own fnid in order to supply a correct whence arg to stuff on
; the page it generates, like logout and delete links.
(def morelink (items label title end newend number)
(tag (a href (url-for
(afnid (fn (req)
(prn)
(let user (get-user req)
(newslog user 'more label)
(longpage user (msec) label title (url-for it)
(display-items user items
label title (url-for it)
end newend number))))))
rel 'nofollow)
(pr "More")))
(def display-story (i s user whence)
(when (or (cansee user s) (s 'kids))
(tr (display-item-number i)
(td (votelinks s user whence))
(titlelink s s!url user))
(tr (tag (td colspan (if i 2 1)))
(tag (td class 'subtext)
(hook 'itemline s user)
(itemline s user)
(when (astory s) (commentlink s user))
(editlink s user)
(when (admin user)
(pr bar*)
(w/rlink (do (zap no s!dead)
(save-item s)
whence)
(pr (if (s 'dead) "unkill" "kill"))))
(deletelink s user whence)))))
(def display-item-number (i)
(when i (tag (td align 'right valign 'top class 'title)
(pr i "."))))
(= follow-threshold* 5)
(def titlelink (s url user)
(tag (td class 'title)
(if (cansee user s)
(do (let toself (blank url)
(tag (a href (if toself (item-url s) url)
rel (unless (or toself
(> (realscore s) follow-threshold*))
'nofollow))
(pr (s 'title))))
(deadmark s user)
(awhen (and (valid-url url) (sitename url))
(spanclass comhead
(pr " (" it ") "))))
(pr (pseudo-text s)))))
(def pseudo-text (i)
(if i!deleted "[deleted]" "[dead]"))
(def deadmark (i user)
(when (and i!dead (seesdead user))
(pr " [dead]"))
(when (and i!deleted (admin user))
(pr " [deleted]")))
(= downvote-threshold* 20 downvote-time* 1440)
(= votewid* 14)
(def votelinks (i user whence (o downtoo))
(center
(if (and (cansee user i)
(or (no user)
(no ((votes* user) i!id))))
(do (votelink i user whence 'up)
(if (and downtoo
(or (admin user)
(< (item-age i) downvote-time*))
(canvote user i 'down))
(do (br)
(votelink i user whence 'down))
(tag (span id (string "down_" i!id)))))
(is user i!by)
(do (tag (font color orange) (pr "*"))
(br)
(hspace votewid*))
(hspace votewid*))))
(def votelink (i user whence dir)
(tag (a id (string dir '_ i!id)
onclick (if user "return vote(this)")
href (if user
(string "vote?by=" user "&for=" i!id "&dir=" dir)
(flink (vote-fn i whence dir))))
(gentag img src (case dir up up-url* down down-url*)
border 0 vspace 3 hspace 2)))
(def vote-fn (i whence dir)
(fn (req)
(login-page 'both "You have to be logged in to vote."
(list (fn (u ip)
(ensure-news-user u)
(newslog u 'vote-login ip)
(vote-for u i dir)
(logvote u i))
whence))))
; Not much stricter than whether to generate the arrow. Further tests
; applied in vote-for.
(def canvote (user i dir)
(and user
(no ((votes* user) i!id))
(or (is dir 'up)
(and (acomment i)
(> (karma user) downvote-threshold*)
(no (aand i!parent (is user ((item it) 'by))))))))
; Can't use this for links when not logged in, because doesn't know
; where to redirect after the login. But that's few fnids anyway
; because pages with those links are cached. Now that have Javascript
; voting, can use for all other votes because never have to regen
; the page.
(newsop vote (by for dir)
(let dir (saferead dir)
(if (isnt by user)
(pr "User mismatch.")
(aif (safe-item for)
(if (and (in dir 'up 'down) (canvote user it dir))
(do (vote-for by it dir)
(logvote by it))
(pr "Can't make that vote."))
(pr "No such item.")))))
(def itemline (i user)
(when (cansee user i)
(when (news-type i)
(tag (span id (string "score_" i!id))
(pr i!score (plural i!score " point"))))
(byline i)))
(def byline (i)
(pr " by ")
(link i!by (user-url i!by))
(pr " " (text-age:item-age i) " "))
(def user-url (user) (+ "user?id=" user))
(def commentlink (i user)
(when (cansee user i) (pr bar*)) ; smells like a hack
(tag (a href (item-url i))
(let n (- (len (visible user (family i))) 1)
(if (> n 0)
(pr n (plural n " comment"))
(pr "discuss")))))
(def family (i) (cons i (mappend family:item i!kids)))
(= user-changetime* 120 editor-changetime* 1440)
(= everchange* (table) noedit* (table))
(def canedit (user i)
(or (admin user)
(and (~noedit* i!type)
(editor user)
(< (item-age i) editor-changetime*))
(own-changeable-item user i)))
(def own-changeable-item (user i)
(and (is user i!by)
(no i!deleted)
(or (everchange* i!type)
(< (item-age i) user-changetime*))))
(def editlink (story user)
(when (canedit user story)
(pr bar*)
(link "edit" (edit-url story))))
(def candelete (user story)
(or (admin user) (own-changeable-item user story)))
(def deletelink (i user whence)
(when (candelete user i)
(pr bar*)
(linkf (if i!deleted "undelete" "delete") (req)
(let user (get-user req)
(if (candelete user i)
(del-confirm-page user i whence)
(prn "You can't delete that."))))))
; Undeleting stories could cause a slight inconsistency. If a story
; linking to x gets deleted, another submission can take its place in
; url->story. If the original is then undeleted, there will be two
; stories with equal claim to be in url->story. (The more recent will
; win because it happens to get loaded later.) Not a big problem.
(def del-confirm-page (user i whence)
(minipage "Confirm"
(tab
(display-item nil
i user
; never used so not testable but think correct
(flink [del-confirm-page (get-user _) i whence]))
(spacerow 20)
(tr (td)
(td (urform user req
(do (when (candelete user i)
(= i!deleted (is (arg req "b") "Yes"))
(save-item i))
whence)
(prn "Do you want this to "
(if i!deleted "remain" "be")
" deleted?")
(br2)
(but "Yes" "b") (sp) (but "No" "b")))))))
(def permalink (story user)