diff options
Diffstat (limited to 'news.arc')
-rw-r--r-- | news.arc | 2617 |
1 files changed, 2617 insertions, 0 deletions
diff --git a/news.arc b/news.arc new file mode 100644 index 0000000..e837d64 --- /dev/null +++ b/news.arc @@ -0,0 +1,2617 @@ +; News. 2 Sep 06. + +; to run news: (nsv), then go to http://localhost:8080 +; put usernames of admins, separated by whitespace, in arc/admins + +; bug: somehow (+ votedir* nil) is getting evaluated. + +(declare 'atstrings t) + +(= 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* (color 180 180 180) + border-color* (color 180 180 180) + prefer-url* t) + + +; 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 + votes nil ; for now just recent, elts each (time id by sitename dir) + karma 1 + avg nil + weight .5 + ignore nil + email nil + about nil + showdead nil + noprocrast nil + firstview nil + lastview nil + maxvisit 20 + minaway 180 + topcolor nil + keys nil + delay 0) + +(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 + flags nil + dead nil + deleted nil + parts nil + parent nil + kids nil + keys nil) + + +; Load and Save + +(= newsdir* "arc/news/" + storydir* "arc/news/story/" + profdir* "arc/news/profile/" + votedir* "arc/news/vote/") + +(= votes* (table) profs* (table)) + +(= initload-users* nil) + +(def nsv ((o port 8080)) + (map ensure-dir (list arcdir* newsdir* storydir* votedir* profdir*)) + (unless stories* (load-items)) + (if (and initload-users* (empty profs*)) (load-users)) + (asv port)) + +(def load-users () + (pr "load users: ") + (noisy-each 100 id (dir profdir*) + (load-user id))) + +; For some reason vote files occasionally get written out in a +; broken way. The nature of the errors (random missing or extra +; chars) suggests the bug is lower-level than anything in Arc. +; Which unfortunately means all lists written to disk are probably +; vulnerable to it, since that's all save-table does. + +(def load-user (u) + (= (votes* u) (load-table (+ votedir* u)) + (profs* u) (temload 'profile (+ profdir* u))) + u) + +; Have to check goodname because some user ids come from http requests. +; So this is like safe-item. Don't need a sep fn there though. + +(def profile (u) + (or (profs* u) + (aand (goodname u) + (file-exists (+ profdir* u)) + (= (profs* u) (temload 'profile it))))) + +(def votes (u) + (or (votes* u) + (aand (file-exists (+ votedir* u)) + (= (votes* u) (load-table it))))) + +(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 (profile 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) `((profile ,u) ',k)) + +(mac karma (u) `(uvar ,u karma)) +(mac ignored (u) `(uvar ,u ignore)) + +; Note that users will now only consider currently loaded users. + +(def users ((o f idfn)) + (keep f (keys profs*))) + +(def check-key (u k) + (and u (mem k (uvar u keys)))) + +(def author (u i) (is u i!by)) + + +(= 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 popular pages. + +(def load-items () + (system (+ "rm " storydir* "*.tmp")) + (pr "load items: ") + (with (items (table) + ids (sort > (map 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 (merge (compare < !id) items!story items!poll)) + 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.") + (flushout) + (gen-topstories)))) + +(def astory (i) (is i!type 'story)) +(def acomment (i) (is i!type 'comment)) +(def apoll (i) (is i!type 'poll)) + +(def load-item (id) + (let i (temload 'item (+ storydir* id)) + (= (items* id) i) + (awhen (and (astory&live i) (check i!url ~blank)) + (register-url i it)) + i)) + +; Note that duplicates are only prevented of items that have at some +; point been loaded. + +(def register-url (i url) + (= (url->story* (canonical-url url)) i!id)) + +; redefined later + +(= stemmable-sites* (table)) + +(def canonical-url (url) + (if (stemmable-sites* (sitename url)) + (cut url 0 (pos #\? url)) + url)) + +(def new-item-id () + (evtil (++ maxid*) [~file-exists (+ storydir* _)])) + +(def item (id) + (or (items* id) (errsafe:load-item id))) + +(def kids (i) (map item i!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) + (ok-id&item (if (isa id 'string) (saferead id) 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 save-item (i) (save-table i (+ storydir* i!id))) + +(def kill (i how) + (unless i!dead + (log-kill i how) + (wipe (comment-cache* i!id)) + (set i!dead) + (save-item i))) + +(= kill-log* nil) + +(def log-kill (i how) + (push (list i!id how) kill-log*)) + +(mac each-loaded-item (var . body) + (w/uniq g + `(let ,g nil + (loop (= ,g maxid*) (> ,g 0) (-- ,g) + (whenlet ,var (items* ,g) + ,@body))))) + +(def loaded-items (test) + (accum a (each-loaded-item i (test&a 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.8 timebase* 120 front-threshold* 1 + nourl-factor* .4 lightweight-factor* .3 ) + +(def frontpage-rank (s (o scorefn realscore) (o gravity gravity*)) + (* (/ (let base (- (scorefn s) 1) + (if (> base 0) (expt base .8) base)) + (expt (/ (+ (item-age s) timebase*) 60) gravity)) + (if (no (in s!type 'story 'poll)) .5 + (blank s!url) nourl-factor* + (lightweight s) (min lightweight-factor* + (contro-factor s)) + (contro-factor s)))) + +(def contro-factor (s) + (aif (check (visible-family nil s) [> _ 20]) + (min 1 (expt (/ (realscore s) it) 2)) + 1)) + +(def realscore (i) (- i!score i!sockvotes)) + +(disktable lightweights* (+ newsdir* "lightweights")) + +(def lightweight (s) + (or s!dead + (mem 'rally s!keys) ; title is a rallying cry + (mem 'image s!keys) ; post is mainly image(s) + (lightweights* (sitename s!url)) + (lightweight-url s!url))) + +(defmemo lightweight-url (url) + (in (downcase (last (tokens url #\.))) "png" "jpg" "jpeg")) + +(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 () + (writefile (map !id (firstn 180 ranked-stories*)) + (+ newsdir* "topstories"))) + +(def rank-stories (n consider scorefn) + (bestn n (compare > scorefn) (latest-items metastory nil consider))) + +; With virtual lists the above call to latest-items could be simply: +; (map item (retrieve consider metastory:item (gen maxid* [- _ 1]))) + +(def latest-items (test (o stop) (o n)) + (accum a + (catch + (down id maxid* 1 + (let i (item id) + (if (or (and stop (stop i)) (and n (<= n 0))) + (throw)) + (when (test i) + (a i) + (if n (-- n)))))))) + +; redefined later + +(def metastory (i) (and i (in i!type 'story 'poll))) + +(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. + +(defbg rerank-random 30 (rerank-random)) + +(def rerank-random () + (when ranked-stories* + (adjust-rank (ranked-stories* (rand (min 50 (len ranked-stories*))))))) + +(def topstories (user n (o threshold front-threshold*)) + (retrieve n + [and (>= (realscore _) threshold) (cansee user _)] + ranked-stories*)) + +(= max-delay* 10) + +(def cansee (user i) + (if i!deleted (admin user) + i!dead (or (author user i) (seesdead user)) + (delayed i) (author user i) + t)) + +(let mature (table) + (def delayed (i) + (and (no (mature i!id)) + (acomment i) + (or (< (item-age i) (min max-delay* (uvar i!by delay))) + (do (set (mature i!id)) + nil))))) + +(def seesdead (user) + (or (and user (uvar user showdead) (no (ignored user))) + (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* "arc.png") + +(defopr favicon.ico req favicon-url*) + +; redefined later + +(def gen-css-url () + (prn "<link rel=\"stylesheet\" type=\"text/css\" href=\"news.css\">")) + +(mac npage (title . body) + `(tag html + (tag head + (gen-css-url) + (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 lid label title whence . body) + (w/uniq (gu gi gl gt gw) + `(with (,gu ,user ,gi ,lid ,gl ,label ,gt ,title ,gw ,whence) + (npage (+ this-site* (if ,gt (+ bar* ,gt) "")) + (if (check-procrast ,gu) + (do (pagetop 'full ,gi ,gl ,gt ,gu ,gw) + (hook 'page ,gu ,gl) + ,@body) + (row (procrast-msg ,gu ,gw))))))) + +(mac longpage (user t1 lid label title whence . body) + (w/uniq (gu gt gi) + `(with (,gu ,user ,gt ,t1 ,gi ,lid) + (fulltop ,gu ,gi ,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 (round (/ (memory) 1000000)) " mb") + (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 lid label title whence . body) + `(fulltop ,user ,lid ,label ,title ,whence + (trtd ,@body))) + +(mac minipage (label . body) + `(npage (+ this-site* bar* ,label) + (pagetop nil nil ,label) + (trtd ,@body))) + +(def msgpage (user msg (o title)) + (minipage (or title "Message") + (spanclass admin + (center (if (len> msg 80) + (widtable 500 msg) + (pr msg)))) + (br2))) + +(= (max-age* 'news.css) 86400) ; cache css in browser for 1 day + +; turn off server caching via (= 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: auto; padding: 2px; max-width:600px; } +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 lid label (o title) (o user) (o whence)) +; (tr (tdcolor black (vspace 5))) + (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*) + (tag (img src logo-url* width 18 height 18 + style "border:1px #@(hexrep border-color*) solid;"))))) + +(= toplabels* '(nil "welcome" "new" "threads" "comments" "leaders" "*")) + +; redefined later + +(= welcome-url* "welcome") + +(def toprow (user label) + (w/bars + (when (noob user) + (toplink "welcome" welcome-url* label)) + (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*) + (fontcolor 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 + (userlink user user nil) + (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 ip u 'top-login)) + whence))))) + +(def noob (user) + (and user (< (days-since (uvar user created)) 1))) + + +; 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 ip user ',name ,@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 nil ,g ,g ,g + ,@body))))) + +(mac edop (name parms . body) + (w/uniq g + `(opexpand defope ,name ,parms + (let ,g (string ',name) + (shortpage user nil ,g ,g ,g + ,@body))))) + + +; News Admin + +(defopa newsadmin req + (let user (get-user req) + (newslog req!ip user 'newsadmin) + (newsadmin-page user))) + +; Note that caching* is reset to val in source when restart server. + +(def nad-fields () + `((num caching ,caching* t t) + (bigtoks comment-kill ,comment-kill* t t) + (bigtoks comment-ignore ,comment-ignore* t t) + (bigtoks lightweights ,(sort < (keys lightweights*)) 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) + (shortpage user nil nil "newsadmin" "newsadmin" + (vars-form user + (nad-fields) + (fn (name val) + (case name + caching (= caching* val) + comment-kill (todisk comment-kill* val) + comment-ignore (todisk comment-ignore* val) + lightweights (todisk lightweights* (memtable val)) + )) + (fn () (newsadmin-page user))) + (br2) + (aform (fn (req) + (with (user (get-user req) subject (arg req "id")) + (if (profile subject) + (do (killallby subject) + (submitted-page user subject)) + (admin&newsadmin-page user)))) + (single-input "" 'id 20 "kill all by")) + (br2) + (aform (fn (req) + (let user (get-user req) + (set-ip-ban user (arg req "ip") t) + (admin&newsadmin-page user))) + (single-input "" 'ip 20 "ban ip")))) + + +; Users + +(newsop user (id) + (if (only.profile id) + (user-page user id) + (pr "No such user."))) + +(def user-page (user subject) + (let here (user-url subject) + (shortpage user nil 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 (profile subject) + (vars-form user + (user-fields user subject) + (fn (name val) + (when (and (is name 'ignore) val (no prof!ignore)) + (log-ignore user subject 'profile)) + (= (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 (profile 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) + (num avg ,(p 'avg) ,a nil) + (yesno ignore ,(p 'ignore) ,e ,e) + (num weight ,(p 'weight) ,a ,a) + (mdtext2 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) + (int delay ,(p 'delay) ,u ,u)))) + +(def saved-link (user subject) + (when (or (admin user) (is user subject)) + (let n (if (len> (votes subject) 500) + "many" + (len (voted-stories user subject))) + (if (is n 0) + "" + (tostring (underlink n (saved-url subject))))))) + +(def resetpw-link () + (tostring (underlink "reset password" "resetpw"))) + +(newsop welcome () + (pr "Welcome to " this-site* ", " user "!")) + + +; Main Operators + +; remember to set caching to 0 when testing non-logged-in + +(= caching* 1 perpage* 30 threads-perpage* 10 maxend* 210) + +; 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 + (listpage user (msec) (topstories user maxend*) nil nil "news")) + +(def listpage (user t1 items label title (o url label) (o number t)) + (hook 'listpage user) + (longpage user t1 nil 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 + (listpage user (msec) (newstories user maxend*) "new" "New Links" "newest")) + +(def newstories (user n) + (retrieve n [cansee user _] stories*)) + + +(newsop best () (bestpage user)) + +(newscache bestpage user 1000 + (listpage user (msec) (beststories user maxend*) "best" "Top Links")) + +; 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 noobstories () (noobspage user stories*)) +(newsop noobcomments () (noobspage user comments*)) + +(def noobspage (user source) + (listpage user (msec) (noobs user maxend* source) "noobs" "New Accounts")) + +(def noobs (user n source) + (retrieve n [and (cansee user _) (bynoob _)] source)) + +(def bynoob (i) + (< (- (user-age i!by) (item-age i)) 2880)) + + +(newsop bestcomments () (bestcpage user)) + +(newscache bestcpage user 1000 + (listpage user (msec) (bestcomments user maxend*) + "best comments" "Best Comments" "bestcomments" nil)) + +(def bestcomments (user n) + (bestn n (compare > realscore) (visible user comments*))) + + +(newsop lists () + (longpage user (msec) nil "lists" "Lists" "lists" + (sptab + (row (link "best") "Highest voted recent links.") + (row (link "active") "Most active current discussions.") + (row (link "bestcomments") "Highest voted recent comments.") + (row (link "noobstories") "Submissions from new accounts.") + (row (link "noobcomments") "Comments from new accounts.") + (when (admin user) + (map row:link + '(optimes topips flagged killed badguys badlogins goodlogins))) + (hook 'listspage user)))) + + +(def saved-url (user) (+ "saved?id=" user)) + +(newsop saved (id) + (if (only.profile 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)) + (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 (cut items start end) + (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 display-items + 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 (f items label title . args) + (tag (a href + (url-for + (afnid (fn (req) + (prn) + (with (url (url-for it) ; it bound by afnid + user (get-user req)) + (newslog req!ip user 'more label) + (longpage user (msec) nil label title url + (apply f user items label title url args)))))) + 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)) + (titleline s s!url user whence)) + (tr (tag (td colspan (if i 2 1))) + (tag (td class 'subtext) + (hook 'itemline s user) + (itemline s user) + (when (in s!type 'story 'poll) (commentlink s user)) + (editlink s user) + (when (apoll s) (addoptlink s user)) + (unless i (flaglink s user whence)) + (killlink s user whence) + (blastlink s user whence) + (blastlink s user whence t) + (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 titleline (s url user whence) + (tag (td class 'title) + (if (cansee user s) + (do (deadmark s user) + (titlelink s url user) + (pdflink url) + (awhen (sitename url) + (spanclass comhead + (pr " (" ) + (if (admin user) + (w/rlink (do (set-site-ban user + it + (case (car (banned-sites* it)) + nil 'ignore + ignore 'kill + kill nil)) + whence) + (let ban (car (banned-sites* it)) + (tag-if ban (font color (case ban + ignore darkred + kill darkblue)) + (pr it)))) + (pr it)) + (pr ") ")))) + (pr (pseudo-text s))))) + +(def titlelink (s url user) + (let toself (blank url) + (tag (a href (if toself + (item-url s!id) + (or (live s) (author user s) (editor user)) + url + nil) + rel (unless (or toself (> (realscore s) follow-threshold*)) + 'nofollow)) + (pr s!title)))) + +(def pdflink (url) + (awhen (vacuumize url) + (pr " [") + (link "scribd" it) + (pr "]"))) + +(defmemo vacuumize (url) + (and (or (endmatch ".pdf" url) (endmatch ".PDF" url)) + (+ "http://www.scribd.com/vacuum?url=" url))) + +(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* 200 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)) + ; don't understand why needed, but is, or a new + ; page is generated on voting + (tag (span id (+ "down_" i!id))))) + (author user i) + (do (fontcolor orange (pr "*")) + (br) + (hspace votewid*)) + (hspace votewid*)))) + +; could memoize votelink more, esp for non-logged in users, +; since only uparrow is shown; could straight memoize + +; redefined later (identically) so the outs catch new vals of up-url, etc. + +(def votelink (i user whence dir) + (tag (a id (if user (string dir '_ i!id)) + onclick (if user "return vote(this)") + href (vote-url user i dir whence)) + (if (is dir 'up) + (out (gentag img src up-url* border 0 vspace 3 hspace 2)) + (out (gentag img src down-url* border 0 vspace 3 hspace 2))))) + +(def vote-url (user i dir whence) + (+ "vote?" "for=" i!id + "&dir=" dir + (if user (+ "&by=" user "&auth=" (user->cookie* user))) + "&whence=" (urlencode whence))) + +(= lowest-score* -4) + +; Not much stricter than whether to generate the arrow. Further tests +; applied in vote-for. + +(def canvote (user i dir) + (and user + (news-type&live i) + (or (is dir 'up) (> i!score lowest-score*)) + (no ((votes user) i!id)) + (or (is dir 'up) + (and (acomment i) + (> (karma user) downvote-threshold*) + (no (aand i!parent (author user (item it)))))))) + +; Need the by argument or someone could trick logged in users into +; voting something up by clicking on a link. But a bad guy doesn't +; know how to generate an auth arg that matches each user's cookie. + +(newsop vote (by for dir auth whence) + (with (i (safe-item for) + dir (saferead dir) + whence (if whence (urldecode whence) "news")) + (if (no i) + (pr "No such item.") + (no (in dir 'up 'down)) + (pr "Can't make that vote.") + (and by (or (isnt by user) (isnt (sym auth) (user->cookie* user)))) + (pr "User mismatch.") + (no user) + (login-page 'both "You have to be logged in to vote." + (list (fn (u ip) + (ensure-news-user u) + (newslog ip u 'vote-login) + (when (canvote u i dir) + (vote-for u i dir) + (logvote ip u i))) + whence)) + (canvote user i dir) + (do (vote-for by i dir) + (logvote ip by i)) + (pr "Can't make that vote.")))) + +(def itemline (i user) + (when (cansee user i) + (when (news-type i) (itemscore i user)) + (byline i user))) + +(def itemscore (i (o user)) + (tag (span id (+ "score_" i!id)) + (pr (plural (if (is i!type 'pollopt) (realscore i) i!score) + "point"))) + (hook 'itemscore i user)) + +; redefined later + +(def byline (i user) + (pr " by @(tostring (userlink user i!by)) @(text-age:item-age i) ")) + +(def user-url (user) (+ "user?id=" user)) + +(= show-avg* nil) + +(def userlink (user subject (o show-avg t)) + (link (user-name user subject) (user-url subject)) + (awhen (and show-avg* (admin user) show-avg (uvar subject avg)) + (pr " (@(num it 1 t t))"))) + +(= noob-color* (color 60 150 60)) + +(def user-name (user subject) + (if (and (editor user) (ignored subject)) + (tostring (fontcolor darkred (pr subject))) + (and (editor user) (< (user-age subject) 1440)) + (tostring (fontcolor noob-color* (pr subject))) + subject)) + +(= show-threadavg* nil) + +(def commentlink (i user) + (when (cansee user i) + (pr bar*) + (tag (a href (item-url i!id)) + (let n (- (visible-family user i) 1) + (if (> n 0) + (do (pr (plural n "comment")) + (awhen (and show-threadavg* (admin user) (threadavg i)) + (pr " (@(num it 1 t t))"))) + (pr "discuss")))))) + +(def visible-family (user i) + (+ (if (cansee user i) 1 0) + (sum [visible-family user (item _)] i!kids))) + +(def threadavg (i) + (only.avg (map [or (uvar _ avg) 1] + (rem admin (dedup (map !by (keep live (family i)))))))) + +(= 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 (author user i) + (~mem 'locked i!keys) + (no i!deleted) + (or (everchange* i!type) + (< (item-age i) user-changetime*)))) + +(def editlink (i user) + (when (canedit user i) + (pr bar*) + (link "edit" (edit-url i)))) + +(def addoptlink (p user) + (when (or (admin user) (author user p)) + (pr bar*) + (onlink "add choice" (add-pollopt-page p user)))) + +; reset later + +(= flag-threshold* 30 flag-kill-threshold* 7 many-flags* 1) + +; Un-flagging something doesn't unkill it, if it's now no longer +; over flag-kill-threshold. Ok, since arbitrary threshold anyway. + +(def flaglink (i user whence) + (when (and user + (isnt user i!by) + (or (admin user) (> (karma user) flag-threshold*))) + (pr bar*) + (w/rlink (do (togglemem user i!flags) + (when (and (~mem 'nokill i!keys) + (len> i!flags flag-kill-threshold*) + (< (realscore i) 10) + (~find admin:!2 i!vote)) + (kill i 'flags)) + whence) + (pr "@(if (mem user i!flags) 'un)flag")) + (when (and (admin user) (len> i!flags many-flags*)) + (pr bar* (plural (len i!flags) "flag") " ") + (w/rlink (do (togglemem 'nokill i!keys) + (save-item i) + whence) + (pr (if (mem 'nokill i!keys) "un-notice" "noted")))))) + +(def killlink (i user whence) + (when (admin user) + (pr bar*) + (w/rlink (do (zap no i!dead) + (if i!dead + (do (pull 'nokill i!keys) + (log-kill i user)) + (pushnew 'nokill i!keys)) + (save-item i) + whence) + (pr "@(if i!dead 'un)kill")))) + +; Blast kills the submission and bans the user. Nuke also bans the +; site, so that all future submitters will be ignored. Does not ban +; the ip address, but that will eventually get banned by maybe-ban-ip. + +(def blastlink (i user whence (o nuke)) + (when (and (admin user) + (or (no nuke) (~empty i!url))) + (pr bar*) + (w/rlink (do (toggle-blast i user nuke) + whence) + (prt (if (ignored i!by) "un-") (if nuke "nuke" "blast"))))) + +(def toggle-blast (i user (o nuke)) + (atomic + (if (ignored i!by) + (do (wipe i!dead (ignored i!by)) + (awhen (and nuke (sitename i!url)) + (set-site-ban user it nil))) + (do (set i!dead) + (ignore user i!by (if nuke 'nuke 'blast)) + (awhen (and nuke (sitename i!url)) + (set-site-ban user it 'ignore)))) + (if i!dead (log-kill i user)) + (save-item i) + (save-prof i!by))) + +(def candelete (user i) + (or (admin user) (own-changeable-item user i))) + +(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 + ; link never used so not testable but think correct + (display-item nil i user (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 'stay 'be) deleted?") + (br2) + (but "Yes" "b") (sp) (but "No" "b"))))))) + +(def permalink (story user) + (when (cansee user story) + (pr bar*) + (link "link" (item-url story!id)))) + +(def logvote (ip user story) + (newslog ip user 'vote (story 'id) (list (story 'title)))) + +(def text-age (a) + (tostring + (if (>= a 1440) (pr (plural (trunc (/ a 1440)) "day") " ago") + (>= a 60) (pr (plural (trunc (/ a 60)) "hour") " ago") + (pr (plural (trunc a) "minute") " ago")))) + + +; Voting + +; A user needs legit-threshold karma for a vote to count if there has +; already been a vote from the same IP address. A new account below both +; new- thresholds won't affect rankings, though such votes still affect +; scores unless not a legit-user. + +(= legit-threshold* 0 new-age-threshold* 0 new-karma-threshold* 2) + +(def legit-user (user) + (or (editor user) + (> (karma user) legit-threshold*))) + +(def possible-sockpuppet (user) + (or (ignored user) + (< (uvar user weight) .5) + (and (< (user-age user) new-age-threshold*) + (< (karma user) new-karma-threshold*)))) + +(= downvote-ratio-limit* .65 recent-votes* nil votewindow* 100) + +; Note: if vote-for by one user changes (s 'score) while s is being +; edited by another, the save after the edit will overwrite the change. +; Actual votes can't be lost because that field is not editable. Not a +; big enough problem to drag in locking. + +(def vote-for (user i (o dir 'up)) + (unless (or ((votes user) i!id) + (and (~live i) (isnt user i!by))) + (withs (ip (logins* user) + vote (list (seconds) ip user dir i!score)) + (unless (or (and (or (ignored user) (check-key user 'novote)) + (isnt user i!by)) + (and (is dir 'down) + (~editor user) + (or (check-key user 'nodowns) + (> (downvote-ratio user) downvote-ratio-limit*) + ; prevention of karma-bombing + (just-downvoted user i!by))) + (and (~legit-user user) + (isnt user i!by) + (find [is (cadr _) ip] i!votes)) + (and (isnt i!type 'pollopt) + (biased-voter i vote))) + (++ i!score (case dir up 1 down -1)) + ; canvote protects against sockpuppet downvote of comments + (when (and (is dir 'up) (possible-sockpuppet user)) + (++ i!sockvotes)) + (metastory&adjust-rank i) + (unless (or (author user i) + (and (is ip i!ip) (~editor user)) + (is i!type 'pollopt)) + (++ (karma i!by) (case dir up 1 down -1)) + (save-prof i!by)) + (wipe (comment-cache* i!id))) + (if (admin user) (pushnew 'nokill i!keys)) + (push vote i!votes) + (save-item i) + (push (list (seconds) i!id i!by (sitename i!url) dir) + (uvar user votes)) + (= ((votes* user) i!id) vote) + (save-votes user) + (zap [firstn votewindow* _] (uvar user votes)) + (save-prof user) + (push (cons i!id vote) recent-votes*)))) + +; redefined later + +(def biased-voter (i vote) nil) + +; ugly to access vote fields by position number + +(def downvote-ratio (user (o sample 20)) + (ratio [is _.1.3 'down] + (keep [let by ((item (car _)) 'by) + (nor (is by user) (ignored by))] + (bestn sample (compare > car:cadr) (tablist (votes user)))))) + +(def just-downvoted (user victim (o n 3)) + (let prev (firstn n (recent-votes-by user)) + (and (is (len prev) n) + (all (fn ((id sec ip voter dir score)) + (and (author victim (item id)) (is dir 'down))) + prev)))) + +; Ugly to pluck out fourth element. Should read votes into a vote +; template. They're stored slightly differently in two diff places: +; in one with the voter in the car and the other without. + +(def recent-votes-by (user) + (keep [is _.3 user] recent-votes*)) + + +; Story Submission + +(newsop submit () + (if user + (submit-page user "" "" t) + (submit-login-warning "" "" t))) + +(def submit-login-warning ((o url) (o title) (o showtext) (o text)) + (login-page 'both "You have to be logged in to submit." + (fn (user ip) + (ensure-news-user user) + (newslog ip user 'submit-login) + (submit-page user url title showtext text)))) + +(def submit-page (user (o url) (o title) (o showtext) (o text "") (o msg)) + (minipage "Submit" + (pagemessage msg) + (urform user req + (process-story (get-user req) + (clean-url (arg req "u")) + (striptags (arg req "t")) + showtext + (and showtext (md-from-form (arg req "x") t)) + req!ip) + (tab + (row "title" (input "t" title 50)) + (if prefer-url* + (do (row "url" (input "u" url 50)) + (when showtext + (row "" "<b>or</b>") + (row "text" (textarea "x" 4 50 (only.pr text))))) + (do (row "text" (textarea "x" 4 50 (only.pr text))) + (row "" "<b>or</b>") + (row "url" (input "u" url 50)))) + (row "" (submit)) + (spacerow 20) + (row "" submit-instructions*))))) + +(= submit-instructions* + "Leave url blank to submit a question for discussion. If there is + no url, the text (if any) will appear at the top of the comments + page. If there is a url, the text will be ignored.") + +; For use by outside code like bookmarklet. +; http://news.domain.com/submitlink?u=http://foo.com&t=Foo +; Added a confirm step to avoid xss hacks. + +(newsop submitlink (u t) + (if user + (submit-page user u t) + (submit-login-warning u t))) + +(= title-limit* 80 + retry* "Please try again." + toolong* "Please make title < @title-limit* characters." + bothblank* "The url and text fields can't both be blank. Please + either supply a url, or if you're asking a question, + put it in the text field." + toofast* "You're submitting too fast. Please slow down. Thanks." + spammage* "Stop spamming us. You're wasting your time.") + +; Only for annoyingly high-volume spammers. For ordinary spammers it's +; enough to ban their sites and ip addresses. + +(disktable big-spamsites* (+ newsdir* "big-spamsites")) + +(def process-story (user url title showtext text ip) + (aif (and (~blank url) (live-story-w/url url)) + (do (vote-for user it) + (item-url it!id)) + (if (no user) + (flink [submit-login-warning url title showtext text]) + (no (and (or (blank url) (valid-url url)) + (~blank title))) + (flink [submit-page user url title showtext text retry*]) + (len> title title-limit*) + (flink [submit-page user url title showtext text toolong*]) + (and (blank url) (blank text)) + (flink [submit-page user url title showtext text bothblank*]) + (let site (sitename url) + (or (big-spamsites* site) (recent-spam site))) + (flink [msgpage user spammage*]) + (oversubmitting user ip 'story url) + (flink [msgpage user toofast*]) + (let s (create-story url (process-title title) text user ip) + (story-ban-test user s ip url) + (when (ignored user) (kill s 'ignored)) + (submit-item user s) + (maybe-ban-ip s) + "newest")))) + +(def submit-item (user i) + (push i!id (uvar user submitted)) + (save-prof user) + (vote-for user i)) + +(def recent-spam (site) + (and (caris (banned-sites* site) 'ignore) + (recent-items [is (sitename _!url) site] 720))) + +(def recent-items (test minutes) + (let cutoff (- (seconds) (* 60 minutes)) + (latest-items test [< _!time cutoff]))) + +; Turn this on when spam becomes a problem. + +(= enforce-oversubmit* nil) + +; New user can't submit more than 2 stories in a 2 hour period. +; Give overeager users the key toofast to make limit permanent. + +(def oversubmitting (user ip kind (o url)) + (and enforce-oversubmit* + (or (check-key user 'toofast) + (ignored user) + (< (user-age user) new-age-threshold*) + (< (karma user) new-karma-threshold*)) + (len> (recent-items [or (author user _) (is _!ip ip)] 180) + (if (is kind 'story) + (if (bad-user user) 0 1) + (if (bad-user user) 1 10))))) + +; Note that by deliberate tricks, someone could submit a story with a +; blank title. + +(diskvar scrubrules* (+ newsdir* "scrubrules")) + +(def process-title (s) + (let s2 (multisubst scrubrules* s) + (zap upcase (s2 0)) + s2)) + +(def live-story-w/url (url) + (aand (url->story* (canonical-url url)) (check (item it) live))) + +(def parse-site (url) + (rev (tokens (cadr (tokens url [in _ #\/ #\?])) #\.))) + +(defmemo sitename (url) + (and (valid-url url) + (let toks (parse-site (rem #\space url)) + (if (isa (saferead (car toks)) 'int) + (tostring (prall toks "" ".")) + (let (t1 t2 t3 . rest) toks + (if (and (~in t3 nil "www") + (or (mem t1 multi-tld-countries*) + (mem t2 long-domains*))) + (+ t3 "." t2 "." t1) + (and t2 (+ t2 "." t1)))))))) + +(= multi-tld-countries* '("uk" "jp" "au" "in" "ph" "tr" "za" "my" "nz" "br" + "mx" "th" "sg" "id" "pk" "eg" "il" "at" "pl")) + +(= long-domains* '("blogspot" "wordpress" "livejournal" "blogs" "typepad" + "weebly" "posterous" "blog-city" "supersized" "dreamhosters" + ; "sampasite" "multiply" "wetpaint" ; all spam, just ban + "eurekster" "blogsome" "edogo" "blog" "com")) + +(def create-story (url title text user ip) + (newslog ip user 'create url (list title)) + (let s (inst 'item 'type 'story 'id (new-item-id) + 'url url 'title title 'text text 'by user 'ip ip) + (save-item s) + (= (items* s!id) s) + (unless (blank url) (register-url s url)) + (push s stories*) + s)) + + +; Bans + +(def ignore (user subject cause) + (set (ignored subject)) + (save-prof subject) + (log-ignore user subject cause)) + +(diskvar ignore-log* (+ newsdir* "ignore-log")) + +(def log-ignore (user subject cause) + (todisk ignore-log* (cons (list subject user cause) ignore-log*))) + +; Kill means stuff with this substring gets killed. Ignore is stronger, +; means that user will be auto-ignored. Eventually this info should +; be stored on disk and not in the source code. + +(disktable banned-ips* (+ newsdir* "banned-ips")) ; was ips +(disktable banned-sites* (+ newsdir* "banned-sites")) ; was sites + +(diskvar comment-kill* (+ newsdir* "comment-kill")) +(diskvar comment-ignore* (+ newsdir* "comment-ignore")) + +(= comment-kill* nil ip-ban-threshold* 3) + +(def set-ip-ban (user ip yesno (o info)) + (= (banned-ips* ip) (and yesno (list user (seconds) info))) + (todisk banned-ips*)) + +(def set-site-ban (user site ban (o info)) + (= (banned-sites* site) (and ban (list ban user (seconds) info))) + (todisk banned-sites*)) + +; Kill submissions from banned ips, but don't auto-ignore users from +; them, because eventually ips will become legit again. + +; Note that ban tests are only applied when a link or comment is +; submitted, not each time it's edited. This will do for now. + +(def story-ban-test (user i ip url) + (site-ban-test user i url) + (ip-ban-test i ip) + (hook 'story-ban-test user i ip url)) + +(def site-ban-test (user i url) + (whenlet ban (banned-sites* (sitename url)) + (if (caris ban 'ignore) (ignore nil user 'site-ban)) + (kill i 'site-ban))) + +(def ip-ban-test (i ip) + (if (banned-ips* ip) (kill i 'banned-ip))) + +(def comment-ban-test (user i ip string kill-list ignore-list) + (when (some [posmatch _ string] ignore-list) + (ignore nil user 'comment-ban)) + (when (or (banned-ips* ip) (some [posmatch _ string] kill-list)) + (kill i 'comment-ban))) + +; An IP is banned when multiple ignored users have submitted over +; ban-threshold* (currently loaded) dead stories from it. + +; Can consider comments too if that later starts to be a problem, +; but the threshold may start to be higher because then you'd be +; dealing with trolls rather than spammers. + +(def maybe-ban-ip (s) + (when (and s!dead (ignored s!by)) + (let bads (loaded-items [and _!dead (astory _) (is _!ip s!ip)]) + (when (and (len> bads ip-ban-threshold*) + (some [and (ignored _!by) (isnt _!by s!by)] bads)) + (set-ip-ban nil s!ip t))))) + +(def killallby (user) + (map [kill _ 'all] (submissions user))) + +; Only called from repl. + +(def kill-whole-thread (c) + (kill c 'thread) + (map kill-whole-thread:item c!kids)) + + +; Polls + +; a way to add a karma threshold for voting in a poll +; or better still an arbitrary test fn, or at least pair of name/threshold. +; option to sort the elements of a poll when displaying +; exclusive field? (means only allow one vote per poll) + +(= poll-threshold* 20) + +(newsop newpoll () + (if (and user (> (karma user) poll-threshold*)) + (newpoll-page user) + (pr "Sorry, you need @poll-threshold* karma to create a poll."))) + +(def newpoll-page (user (o title "Poll: ") (o text "") (o opts "") (o msg)) + (minipage "New Poll" + (pagemessage msg) + (urform user req + (process-poll (get-user req) + (striptags (arg req "t")) + (md-from-form (arg req "x") t) + (striptags (arg req "o")) + req!ip) + (tab + (row "title" (input "t" title 50)) + (row "text" (textarea "x" 4 50 (only.pr text))) + (row "" "Use blank lines to separate choices:") + (row "choices" (textarea "o" 7 50 (only.pr opts))) + (row "" (submit)))))) + +(= fewopts* "A poll must have at least two options.") + +(def process-poll (user title text opts ip) + (if (or (blank title) (blank opts)) + (flink [newpoll-page user title text opts retry*]) + (len> title title-limit*) + (flink [newpoll-page user title text opts toolong*]) + (len< (paras opts) 2) + (flink [newpoll-page user title text opts fewopts*]) + (atlet p (create-poll (multisubst scrubrules* title) text opts user ip) + (ip-ban-test p ip) + (when (ignored user) (kill p 'ignored)) + (submit-item user p) + (maybe-ban-ip p) + "newest"))) + +(def create-poll (title text opts user ip) + (newslog ip user 'create-poll title) + (let p (inst 'item 'type 'poll 'id (new-item-id) + 'title title 'text text 'by user 'ip ip) + (= p!parts (map get!id (map [create-pollopt p nil nil _ user ip] + (paras opts)))) + (save-item p) + (= (items* p!id) p) + (push p stories*) + p)) + +(def create-pollopt (p url title text user ip) + (let o (inst 'item 'type 'pollopt 'id (new-item-id) + 'url url 'title title 'text text 'parent p!id + 'by user 'ip ip) + (save-item o) + (= (items* o!id) o) + o)) + +(def add-pollopt-page (p user) + (minipage "Add Poll Choice" + (urform user req + (do (add-pollopt user p (striptags (arg req "x")) req!ip) + (item-url p!id)) + (tab + (row "text" (textarea "x" 4 50)) + (row "" (submit)))))) + +(def add-pollopt (user p text ip) + (unless (blank text) + (atlet o (create-pollopt p nil nil text user ip) + (++ p!parts (list o!id)) + (save-item p)))) + +(def display-pollopts (p user whence) + (each o (visible user (map item p!parts)) + (display-pollopt nil o user whence) + (spacerow 7))) + +(def display-pollopt (n o user whence) + (tr (display-item-number n) + (tag (td valign 'top) + (votelinks o user whence)) + (tag (td class 'comment) + (tag (div style "margin-top:1px;margin-bottom:0px") + (if (~cansee user o) (pr (pseudo-text o)) + (~live o) (spanclass dead + (pr (if (~blank o!title) o!title o!text))) + (if (and (~blank o!title) (~blank o!url)) + (link o!title o!url) + (fontcolor black (pr o!text))))))) + (tr (if n (td)) + (td) + (tag (td class 'default) + (spanclass comhead + (itemscore o) + (editlink o user) + (killlink o user whence) + (deletelink o user whence) + (deadmark o user))))) + + +; Individual Item Page (= Comments Page of Stories) + +(defmemo item-url (id) (+ "item?id=" id)) + +(newsop item (id) + (let s (safe-item id) + (if (news-type s) + (do (if s!deleted (note-baditem user ip)) + (item-page user s)) + (do (note-baditem user ip) + (pr "No such item."))))) + +(= baditemreqs* (table) baditem-threshold* 1/100) + +; Something looking at a lot of deleted items is probably the bad sort +; of crawler. Throttle it for this server invocation. + +(def note-baditem (user ip) + (unless (admin user) + (++ (baditemreqs* ip 0)) + (with (r (requests/ip* ip) b (baditemreqs* ip)) + (when (and (> r 500) (> (/ b r) baditem-threshold*)) + (set (throttle-ips* ip)))))) + +; redefined later + +(def news-type (i) (and i (in i!type 'story 'comment 'poll 'pollopt))) + +(def item-page (user i) + (with (title (and (cansee user i) + (or i!title (aand i!text (ellipsize (striptags it))))) + here (item-url i!id)) + (longpage user (msec) nil nil title here + (tab (display-item nil i user here) + (display-item-text i user) + (when (apoll i) + (spacerow 10) + (tr (td) + (td (tab (display-pollopts i user here))))) + (when (and (cansee user i) (comments-active i)) + (spacerow 10) + (row "" (comment-form i user here)))) + (br2) + (when (and i!kids (commentable i)) + (tab (display-subcomments i user here)) + (br2))))) + +(def commentable (i) (in i!type 'story 'comment 'poll)) + +; By default the ability to comment on an item is turned off after +; 45 days, but this can be overriden with commentable key. + +(= commentable-threshold* (* 60 24 45)) + +(def comments-active (i) + (and (live&commentable i) + (live (superparent i)) + (or (< (item-age i) commentable-threshold*) + (mem 'commentable i!keys)))) + + +(= displayfn* (table)) + +(= (displayfn* 'story) (fn (n i user here inlist) + (display-story n i user here))) + +(= (displayfn* 'comment) (fn (n i user here inlist) + (display-comment n i user here nil 0 nil inlist))) + +(= (displayfn* 'poll) (displayfn* 'story)) + +(= (displayfn* 'pollopt) (fn (n i user here inlist) + (display-pollopt n i user here))) + +(def display-item (n i user here (o inlist)) + ((displayfn* (i 'type)) n i user here inlist)) + +(def superparent (i) + (aif i!parent (superparent:item it) i)) + +(def display-item-text (s user) + (when (and (cansee user s) + (in s!type 'story 'poll) + (blank s!url) + (~blank s!text)) + (spacerow 2) + (row "" s!text))) + + +; Edit Item + +(def edit-url (i) (+ "edit?id=" i!id)) + +(newsop edit (id) + (let i (safe-item id) + (if (and i + (cansee user i) + (editable-type i) + (or (news-type i) (admin user) (author user i))) + (edit-page user i) + (pr "No such item.")))) + +(def editable-type (i) (fieldfn* i!type)) + +(= fieldfn* (table)) + +(= (fieldfn* 'story) + (fn (user s) + (with (a (admin user) e (editor user) x (canedit user s)) + `((string1 title ,s!title t ,x) + (url url ,s!url t ,e) + (mdtext2 text ,s!text t ,x) + ,@(standard-item-fields s a e x))))) + +(= (fieldfn* 'comment) + (fn (user c) + (with (a (admin user) e (editor user) x (canedit user c)) + `((mdtext text ,c!text t ,x) + ,@(standard-item-fields c a e x))))) + +(= (fieldfn* 'poll) + (fn (user p) + (with (a (admin user) e (editor user) x (canedit user p)) + `((string1 title ,p!title t ,x) + (mdtext2 text ,p!text t ,x) + ,@(standard-item-fields p a e x))))) + +(= (fieldfn* 'pollopt) + (fn (user p) + (with (a (admin user) e (editor user) x (canedit user p)) + `((string title ,p!title t ,x) + (url url ,p!url t ,x) + (mdtext2 text ,p!text t ,x) + ,@(standard-item-fields p a e x))))) + +(def standard-item-fields (i a e x) + `((int votes ,(len i!votes) ,a nil) + (int score ,i!score t ,a) + (int sockvotes ,i!sockvotes ,a ,a) + (yesno dead ,i!dead ,e ,e) + (yesno deleted ,i!deleted ,a ,a) + (sexpr flags ,i!flags ,a nil) + (sexpr keys ,i!keys ,a ,a) + (string ip ,i!ip ,e nil))) + +; Should check valid-url etc here too. In fact make a fn that +; does everything that has to happen after submitting a story, +; and call it both there and here. + +(def edit-page (user i) + (let here (edit-url i) + (shortpage user nil nil "Edit" here + (tab (display-item nil i user here) + (display-item-text i user)) + (br2) + (vars-form user + ((fieldfn* i!type) user i) + (fn (name val) + (unless (ignore-edit user i name val) + (when (and (is name 'dead) val (no i!dead)) + (log-kill i user)) + (= (i name) val))) + (fn () (if (admin user) (pushnew 'locked i!keys)) + (save-item i) + (metastory&adjust-rank i) + (wipe (comment-cache* i!id)) + (edit-page user i))) + (hook 'edit user i)))) + +(def ignore-edit (user i name val) + (case name title (len> val title-limit*) + dead (and (mem 'nokill i!keys) (~admin user)))) + + +; Comment Submission + +(def comment-login-warning (parent whence (o text)) + (login-page 'both "You have to be logged in to comment." + (fn (u ip) + (ensure-news-user u) + (newslog ip u 'comment-login) + (addcomment-page parent u whence text)))) + +(def addcomment-page (parent user whence (o text) (o msg)) + (minipage "Add Comment" + (pagemessage msg) + (tab + (let here (flink [addcomment-page parent (get-user _) whence text msg]) + (display-item nil parent user here)) + (spacerow 10) + (row "" (comment-form parent user whence text))))) + +(= noob-comment-msg* nil) + +; Comment forms last for 30 min (- cache time) + +(def comment-form (parent user whence (o text)) + (tarform 1800 + (fn (req) + (when-umatch/r user req + (process-comment user parent (arg req "text") req!ip whence))) + (textarea "text" 6 60 + (aif text (prn (unmarkdown it)))) + (when (and noob-comment-msg* (noob user)) + (br2) + (spanclass subtext (pr noob-comment-msg*))) + (br2) + (submit (if (acomment parent) "reply" "add comment")))) + +(= comment-threshold* -20) + +; Have to remove #\returns because a form gives you back "a\r\nb" +; instead of just "a\nb". Maybe should just remove returns from +; the vals coming in from any form, e.g. in aform. + +(def process-comment (user parent text ip whence) + (if (no user) + (flink [comment-login-warning parent whence text]) + (empty text) + (flink [addcomment-page parent (get-user _) whence text retry*]) + (oversubmitting user ip 'comment) + (flink [msgpage user toofast*]) + (atlet c (create-comment parent (md-from-form text) user ip) + (comment-ban-test user c ip text comment-kill* comment-ignore*) + (if (bad-user user) (kill c 'ignored/karma)) + (submit-item user c) + whence))) + +(def bad-user (u) + (or (ignored u) (< (karma u) comment-threshold*))) + +(def create-comment (parent text user ip) + (newslog ip user 'comment (parent 'id)) + (let c (inst 'item 'type 'comment 'id (new-item-id) + 'text text 'parent parent!id 'by user 'ip ip) + (save-item c) + (= (items* c!id) c) + (push c!id parent!kids) + (save-item parent) + (push c comments*) + c)) + + +; Comment Display + +(def display-comment-tree (c user whence (o indent 0) (o initialpar)) + (when (cansee-descendant user c) + (display-1comment c user whence indent initialpar) + (display-subcomments c user whence (+ indent 1)))) + +(def display-1comment (c user whence indent showpar) + (row (tab (display-comment nil c user whence t indent showpar showpar)))) + +(def display-subcomments (c user whence (o indent 0)) + (each k (sort (compare > frontpage-rank:item) c!kids) + (display-comment-tree (item k) user whence indent))) + +(def display-comment (n c user whence (o astree) (o indent 0) + (o showpar) (o showon)) + (tr (display-item-number n) + (when astree (td (hspace (* indent 40)))) + (tag (td valign 'top) (votelinks c user whence t)) + (display-comment-body c user whence astree indent showpar showon))) + +; Comment caching doesn't make generation of comments significantly +; faster, but may speed up everything else by generating less garbage. + +; It might solve the same problem more generally to make html code +; more efficient. + +(= comment-cache* (table) comment-cache-timeout* (table) cc-window* 10000) + +(= comments-printed* 0 cc-hits* 0) + +(= comment-caching* t) + +; Cache comments generated for nil user that are over an hour old. +; Only try to cache most recent 10k items. But this window moves, +; so if server is running a long time could have more than that in +; cache. Probably should actively gc expired cache entries. + +(def display-comment-body (c user whence astree indent showpar showon) + (++ comments-printed*) + (if (and comment-caching* + astree (no showpar) (no showon) + (live c) + (nor (admin user) (editor user) (author user c)) + (< (- maxid* c!id) cc-window*) + (> (- (seconds) c!time) 60)) ; was 3600 + (pr (cached-comment-body c user whence indent)) + (gen-comment-body c user whence astree indent showpar showon))) + +(def cached-comment-body (c user whence indent) + (or (and (> (or (comment-cache-timeout* c!id) 0) (seconds)) + (awhen (comment-cache* c!id) + (++ cc-hits*) + it)) + (= (comment-cache-timeout* c!id) + (cc-timeout c!time) + (comment-cache* c!id) + (tostring (gen-comment-body c user whence t indent nil nil))))) + +; Cache for the remainder of the current minute, hour, or day. + +(def cc-timeout (t0) + (let age (- (seconds) t0) + (+ t0 (if (< age 3600) + (* (+ (trunc (/ age 60)) 1) 60) + (< age 86400) + (* (+ (trunc (/ age 3600)) 1) 3600) + (* (+ (trunc (/ age 86400)) 1) 86400))))) + +(def gen-comment-body (c user whence astree indent showpar showon) + (tag (td class 'default) + (let parent (and (or (no astree) showpar) (c 'parent)) + (tag (div style "margin-top:2px; margin-bottom:-10px; ") + (spanclass comhead + (itemline c user) + (permalink c user) + (when parent + (when (cansee user c) (pr bar*)) + (link "parent" (item-url ((item parent) 'id)))) + (editlink c user) + (killlink c user whence) + (blastlink c user whence) + (deletelink c user whence) + ; a hack to check whence but otherwise need an arg just for this + (unless (or astree (is whence "newcomments")) + (flaglink c user whence)) + (deadmark c user) + (when showon + (pr " | on: ") + (let s (superparent c) + (link (ellipsize s!title 50) (item-url s!id)))))) + (when (or parent (cansee user c)) + (br)) + (spanclass comment + (if (~cansee user c) (pr (pseudo-text c)) + (nor (live c) (author user c)) (spanclass dead (pr c!text)) + (fontcolor (comment-color c) + (pr c!text)))) + (when (and astree (cansee user c) (live c)) + (para) + (tag (font size 1) + (if (and (~mem 'neutered c!keys) + (replyable c indent) + (comments-active c)) + (underline (replylink c whence)) + (fontcolor sand (pr "-----")))))))) + +; For really deeply nested comments, caching could add another reply +; delay, but that's ok. + +; People could beat this by going to the link url or manually entering +; the reply url, but deal with that if they do. + +(= reply-decay* 1.8) ; delays: (0 0 1 3 7 12 18 25 33 42 52 63) + +(def replyable (c indent) + (or (< indent 2) + (> (item-age c) (expt (- indent 1) reply-decay*)))) + +(def replylink (i whence (o title 'reply)) + (link title (+ "reply?id=" i!id "&whence=" (urlencode whence)))) + +(newsop reply (id whence) + (with (i (safe-item id) + whence (or (only.urldecode whence) "news")) + (if (only.comments-active i) + (if user + (addcomment-page i user whence) + (login-page 'both "You have to be logged in to comment." + (fn (u ip) + (ensure-news-user u) + (newslog ip u 'comment-login) + (addcomment-page i u whence)))) + (pr "No such item.")))) + +(def comment-color (c) + (if (> c!score 0) black (grayrange c!score))) + +(defmemo grayrange (s) + (gray (min 230 (round (expt (* (+ (abs s) 2) 900) .6))))) + + +; Threads + +(def threads-url (user) (+ "threads?id=" user)) + +(newsop threads (id) + (if id + (threads-page user id) + (pr "No user specified."))) + +(def threads-page (user subject) + (if (profile subject) + (withs (title (+ subject "'s comments") + label (if (is user subject) "threads" title) + here (threads-url subject)) + (longpage user (msec) nil label title here + (awhen (keep [and (cansee user _) (~subcomment _)] + (comments subject maxend*)) + (display-threads user it label title here)))) + (prn "No such user."))) + +(def display-threads (user comments label title whence + (o start 0) (o end threads-perpage*)) + (tab + (each c (cut comments start end) + (display-comment-tree c user whence 0 t)) + (when end + (let newend (+ end threads-perpage*) + (when (and (<= newend maxend*) (< end (len comments))) + (spacerow 10) + (row (tab (tr (td (hspace 0)) + (td (hspace votewid*)) + (tag (td class 'title) + (morelink display-threads + comments label title end newend)))))))))) + +(def submissions (user (o limit)) + (map item (firstn limit (uvar user submitted)))) + +(def comments (user (o limit)) + (map item (retrieve limit acomment:item (uvar user submitted)))) + +(def subcomment (c) + (some [and (acomment _) (is _!by c!by) (no _!deleted)] + (ancestors c))) + +(def ancestors (i) + (accum a (trav i!parent a:item self:!parent:item))) + + +; Submitted + +(def submitted-url (user) (+ "submitted?id=" user)) + +(newsop submitted (id) + (if id + (submitted-page user id) + (pr "No user specified."))) + +(def submitted-page (user subject) + (if (profile subject) + (with (label (+ subject "'s submissions") + here (submitted-url subject)) + (longpage user (msec) nil label label here + (if (or (no (ignored subject)) + (is user subject) + (seesdead user)) + (aif (keep [and (metastory _) (cansee user _)] + (submissions subject)) + (display-items user it label label here 0 perpage* t))))) + (pr "No such user."))) + + +; RSS + +(newsop rss () (rsspage nil)) + +(newscache rsspage user 90 + (rss-stories (retrieve perpage* live ranked-stories*))) + +(def rss-stories (stories) + (tag (rss version "2.0") + (tag channel + (tag title (pr this-site*)) + (tag link (pr site-url*)) + (tag description (pr site-desc*)) + (each s stories + (tag item + (let comurl (+ site-url* (item-url s!id)) + (tag title (pr (eschtml s!title))) + (tag link (pr (if (blank s!url) comurl (eschtml s!url)))) + (tag comments (pr comurl)) + (tag description + (cdata (link "Comments" comurl))))))))) + + +; User Stats + +(newsop leaders () (leaderspage user)) + +(= nleaders* 20) + +(newscache leaderspage user 1000 + (longpage user (msec) nil "leaders" "Leaders" "leaders" + (sptab + (let i 0 + (each u (firstn nleaders* (leading-users)) + (tr (tdr:pr (++ i) ".") + (td (userlink user u nil)) + (tdr:pr (karma u)) + (when (admin user) + (tdr:prt (only.num (uvar u avg) 2 t t)))) + (if (is i 10) (spacerow 30))))))) + +(= leader-threshold* 1) ; redefined later + +(def leading-users () + (sort (compare > [karma _]) + (users [and (> (karma _) leader-threshold*) (~admin _)]))) + +(adop editors () + (tab (each u (users [is (uvar _ auth) 1]) + (row (userlink user u))))) + + +(= update-avg-threshold* 0) ; redefined later + +(defbg update-avg 45 + (unless (or (empty profs*) (no stories*)) + (update-avg (rand-user [and (only.> (car (uvar _ submitted)) + (- maxid* initload*)) + (len> (uvar _ submitted) + update-avg-threshold*)])))) + +(def update-avg (user) + (= (uvar user avg) (comment-score user)) + (save-prof user)) + +(def rand-user ((o test idfn)) + (evtil (rand-key profs*) test)) + +; Ignore the most recent 5 comments since they may still be gaining votes. +; Also ignore the highest-scoring comment, since possibly a fluff outlier. + +(def comment-score (user) + (aif (check (nthcdr 5 (comments user 50)) [len> _ 10]) + (avg (cdr (sort > (map !score (rem !deleted it))))) + nil)) + + +; Comment Analysis + +; Instead of a separate active op, should probably display this info +; implicitly by e.g. changing color of commentlink or by showing the +; no of comments since that user last looked. + +(newsop active () (active-page user)) + +(newscache active-page user 600 + (listpage user (msec) (actives user) "active" "Active Threads")) + +(def actives (user (o n maxend*) (o consider 2000)) + (visible user (rank-stories n consider (memo active-rank)))) + +(= active-threshold* 1500) + +(def active-rank (s) + (sum [max 0 (- active-threshold* (item-age _))] + (cdr (family s)))) + +(def family (i) (cons i (mappend family:item i!kids))) + + +(newsop newcomments () (newcomments-page user)) + +(newscache newcomments-page user 60 + (listpage user (msec) (visible user (firstn maxend* comments*)) + "comments" "New Comments" "newcomments" nil)) + + +; Doc + +(defop formatdoc req + (msgpage (get-user req) formatdoc* "Formatting Options")) + +(= formatdoc-url* "formatdoc") + +(= formatdoc* +"Blank lines separate paragraphs. +<p> Text after a blank line that is indented by two or more spaces is +reproduced verbatim. (This is intended for code.) +<p> Text surrounded by asterisks is italicized, if the character after the +first asterisk isn't whitespace. +<p> Urls become links, except in the text field of a submission.<br><br>") + + +; Noprocrast + +(def check-procrast (user) + (or (no user) + (no (uvar user noprocrast)) + (let now (seconds) + (unless (uvar user firstview) + (reset-procrast user)) + (or (when (< (/ (- now (uvar user firstview)) 60) + (uvar user maxvisit)) + (= (uvar user lastview) now) + (save-prof user) + t) + (when (> (/ (- now (uvar user lastview)) 60) + (uvar user minaway)) + (reset-procrast user) + t))))) + +(def reset-procrast (user) + (= (uvar user lastview) (= (uvar user firstview) (seconds))) + (save-prof user)) + +(def procrast-msg (user whence) + (let m (+ 1 (trunc (- (uvar user minaway) + (minutes-since (uvar user lastview))))) + (pr "<b>Get back to work!</b>") + (para "Sorry, you can't see this page. Based on the anti-procrastination + parameters you set in your profile, you'll be able to use the site + again in " (plural m "minute") ".") + (para "(If you got this message after submitting something, don't worry, + the submission was processed.)") + (para "To change your anti-procrastination settings, go to your profile + by clicking on your username. If <tt>noprocrast</tt> is set to + <tt>yes</tt>, you'll be limited to sessions of <tt>maxvisit</tt> + minutes, with <tt>minaway</tt> minutes between them.") + (para) + (w/rlink whence (underline (pr "retry"))) + ; (hspace 20) + ; (w/rlink (do (reset-procrast user) whence) (underline (pr "override"))) + (br2))) + + +; Reset PW + +(defopg resetpw req (resetpw-page (get-user req))) + +(def resetpw-page (user (o msg)) + (minipage "Reset Password" + (if msg + (pr msg) + (blank (uvar user email)) + (do (pr "Before you do this, please add your email address to your ") + (underlink "profile" (user-url user)) + (pr ". Otherwise you could lose your account if you mistype + your new password."))) + (br2) + (uform user req (try-resetpw user (arg req "p")) + (single-input "New password: " 'p 20 "reset" t)))) + +(def try-resetpw (user newpw) + (if (len< newpw 4) + (resetpw-page user "Passwords should be a least 4 characters long. + Please choose another.") + (do (set-pw user newpw) + (newspage user)))) + + +; Scrubrules + +(defopa scrubrules req + (scrub-page (get-user req) scrubrules*)) + +; If have other global alists, generalize an alist edit page. +; Or better still generalize vars-form. + +(def scrub-page (user rules (o msg nil)) + (minipage "Scrubrules" + (when msg (pr msg) (br2)) + (uform user req + (with (froms (lines (arg req "from")) + tos (lines (arg req "to"))) + (if (is (len froms) (len tos)) + (do (todisk scrubrules* (map list froms tos)) + (scrub-page user scrubrules* "Changes saved.")) + (scrub-page user rules "To and from should be same length."))) + (pr "From: ") + (tag (textarea name 'from + cols (apply max 20 (map len (map car rules))) + rows (+ (len rules) 3)) + (apply pr #\newline (intersperse #\newline (map car rules)))) + (pr " To: ") + (tag (textarea name 'to + cols (apply max 20 (map len (map cadr rules))) + rows (+ (len rules) 3)) + (apply pr #\newline (intersperse #\newline (map cadr rules)))) + (br2) + (submit "update")))) + + +; Abuse Analysis + +(adop badsites () + (sptab + (row "Dead" "Days" "Site" "O" "K" "I" "Users") + (each (site deads) (with (banned (banned-site-items) + pairs (killedsites)) + (+ pairs (map [list _ (banned _)] + (rem (fn (d) + (some [caris _ d] pairs)) + (keys banned-sites*))))) + (let ban (car (banned-sites* site)) + (tr (tdr (when deads + (onlink (len deads) + (listpage user (msec) deads + nil (+ "killed at " site) "badsites")))) + (tdr (when deads (pr (round (days-since ((car deads) 'time)))))) + (td site) + (td (w/rlink (do (set-site-ban user site nil) "badsites") + (fontcolor (if ban gray.220 black) (pr "x")))) + (td (w/rlink (do (set-site-ban user site 'kill) "badsites") + (fontcolor (case ban kill darkred gray.220) (pr "x")))) + (td (w/rlink (do (set-site-ban user site 'ignore) "badsites") + (fontcolor (case ban ignore darkred gray.220) (pr "x")))) + (td (each u (dedup (map !by deads)) + (userlink user u nil) + (pr " ")))))))) + +(defcache killedsites 300 + (let bads (table [each-loaded-item i + (awhen (and i!dead (sitename i!url)) + (push i (_ it)))]) + (with (acc nil deadcount (table)) + (each (site items) bads + (let n (len items) + (when (> n 2) + (= (deadcount site) n) + (insort (compare > deadcount:car) + (list site (rev items)) + acc)))) + acc))) + +(defcache banned-site-items 300 + (table [each-loaded-item i + (awhen (and i!dead (check (sitename i!url) banned-sites*)) + (push i (_ it)))])) + +; Would be nice to auto unban ips whose most recent submission is > n +; days old, but hard to do because of lazy loading. Would have to keep +; a table of most recent submission per ip, and only enforce bannnedness +; if < n days ago. + +(adop badips () + (withs ((bads goods) (badips) + (subs ips) (sorted-badips bads goods)) + (sptab + (row "IP" "Days" "Dead" "Live" "Users") + (each ip ips + (tr (td (let banned (banned-ips* ip) + (w/rlink (do (set-ip-ban user ip (no banned)) + "badips") + (fontcolor (if banned darkred) (pr ip))))) + (tdr (when (or (goods ip) (bads ip)) + (pr (round (days-since + (max (aif (car (goods ip)) it!time 0) + (aif (car (bads ip)) it!time 0))))))) + (tdr (onlink (len (bads ip)) + (listpage user (msec) (bads ip) + nil (+ "dead from " ip) "badips"))) + (tdr (onlink (len (goods ip)) + (listpage user (msec) (goods ip) + nil (+ "live from " ip) "badips"))) + (td (each u (subs ip) + (userlink user u nil) + (pr " ")))))))) + +(defcache badips 300 + (with (bads (table) goods (table)) + (each-loaded-item s + (if (and s!dead (commentable s)) + (push s (bads s!ip)) + (push s (goods s!ip)))) + (each (k v) bads (zap rev (bads k))) + (each (k v) goods (zap rev (goods k))) + (list bads goods))) + +(def sorted-badips (bads goods) + (withs (ips (let ips (rem [len< (bads _) 2] (keys bads)) + (+ ips (rem [mem _ ips] (keys banned-ips*)))) + subs (table + [each ip ips + (= (_ ip) (dedup (map !by (+ (bads ip) (goods ip)))))])) + (list subs + (sort (compare > (memo [badness (subs _) (bads _) (goods _)])) + ips)))) + +(def badness (subs bads goods) + (* (/ (len bads) + (max .9 (expt (len goods) 2)) + (expt (+ (days-since (aif (car bads) it!time 0)) + 1) + 2)) + (if (len> subs 1) 20 1))) + + +(edop flagged () + (display-selected-items user [retrieve maxend* flagged _] "flagged")) + +(def flagged (i) + (and (live i) + (~mem 'nokill i!keys) + (len> i!flags many-flags*))) + + +(edop killed () + (display-selected-items user [retrieve maxend* !dead _] "killed")) + +(def display-selected-items (user f whence) + (display-items user (f stories*) nil nil whence) + (vspace 35) + (color-stripe textgray) + (vspace 35) + (display-items user (f comments*) nil nil whence)) + + +; Rather useless thus; should add more data. + +(adop badguys () + (tab (each u (sort (compare > [uvar _ created]) + (users [ignored _])) + (row (userlink user u nil))))) + +(adop badlogins () (logins-page bad-logins*)) + +(adop goodlogins () (logins-page good-logins*)) + +(def logins-page (source) + (sptab (each (time ip user) (firstn 100 (rev (qlist source))) + (row time ip user)))) + + +; Stats + +(adop optimes () + (sptab + (tr (td "op") (tdr "avg") (tdr "med") (tdr "req") (tdr "total")) + (spacerow 10) + (each name (sort < newsop-names*) + (tr (td name) + (let ms (only.avg (qlist (optimes* name))) + (tdr:prt (only.round ms)) + (tdr:prt (only.med (qlist (optimes* name)))) + (let n (opcounts* name) + (tdr:prt n) + (tdr:prt (and n (round (/ (* n ms) 1000)))))))))) + +(defop topcolors req + (minipage "Custom Colors" + (tab + (each c (dedup (map downcase (trues [uvar _ topcolor] (users)))) + (tr (td c) (tdcolor (hex>color c) (hspace 30))))))) + + |