diff --git a/lib/blog.arc b/lib/blog.arc
deleted file mode 100644
index 211dd63..0000000
--- a/lib/blog.arc
+++ /dev/null
@@ -1,95 +0,0 @@
-; Blog tool example. 20 Jan 08, rev 21 May 09.
-
-; To run:
-; arc> (load "blog.arc")
-; arc> (bsv)
-; go to http://localhost:8080/blog
-
-(= postdir* "arc/posts/" maxid* 0 posts* (table))
-
-(= blogtitle* "A Blog")
-
-(deftem post id nil title nil text nil)
-
-(def load-posts ()
- (each id (map int (dir postdir*))
- (= maxid* (max maxid* id)
- (posts* id) (temload 'post (string postdir* id)))))
-
-(def save-post (p) (save-table p (string postdir* p!id)))
-
-(def post (id) (posts* (errsafe:int id)))
-
-(mac blogpage body
- `(whitepage
- (center
- (widtable 600
- (tag b (link blogtitle* "blog"))
- (br 3)
- ,@body
- (br 3)
- (w/bars (link "archive")
- (link "new post" "newpost"))))))
-
-(defop viewpost req (blogop post-page req))
-
-(def blogop (f req)
- (aif (post (arg req "id"))
- (f (get-user req) it)
- (blogpage (pr "No such post."))))
-
-(def permalink (p) (string "viewpost?id=" p!id))
-
-(def post-page (user p) (blogpage (display-post user p)))
-
-(def display-post (user p)
- (tag b (link p!title (permalink p)))
- (when user
- (sp)
- (link "[edit]" (string "editpost?id=" p!id)))
- (br2)
- (pr p!text))
-
-(defopl newpost req
- (whitepage
- (aform [let u (get-user _)
- (post-page u (addpost u (arg _ "t") (arg _ "b")))]
- (tab (row "title" (input "t" "" 60))
- (row "text" (textarea "b" 10 80))
- (row "" (submit))))))
-
-(def addpost (user title text)
- (let p (inst 'post 'id (++ maxid*) 'title title 'text text)
- (save-post p)
- (= (posts* p!id) p)))
-
-(defopl editpost req (blogop edit-page req))
-
-(def edit-page (user p)
- (whitepage
- (vars-form user
- `((string title ,p!title t t) (text text ,p!text t t))
- (fn (name val) (= (p name) val))
- (fn () (save-post p)
- (post-page user p)))))
-
-(defop archive req
- (blogpage
- (tag ul
- (each p (map post (rev (range 1 maxid*)))
- (tag li (link p!title (permalink p)))))))
-
-(defop blog req
- (let user (get-user req)
- (blogpage
- (for i 0 4
- (awhen (posts* (- maxid* i))
- (display-post user it)
- (br 3))))))
-
-(def bsv ()
- (ensure-dir postdir*)
- (load-posts)
- (asv))
-
-
diff --git a/lib/news.arc b/lib/news.arc
deleted file mode 100644
index e837d64..0000000
--- a/lib/news.arc
+++ /dev/null
@@ -1,2617 +0,0 @@
-; 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 ""))
-
-(mac npage (title . body)
- `(tag html
- (tag head
- (gen-css-url)
- (prn "")
- (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 . 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 "" "or")
- (row "text" (textarea "x" 4 50 (only.pr text)))))
- (do (row "text" (textarea "x" 4 50 (only.pr text)))
- (row "" "or")
- (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.
- Text after a blank line that is indented by two or more spaces is
-reproduced verbatim. (This is intended for code.)
-
Text surrounded by asterisks is italicized, if the character after the
-first asterisk isn't whitespace.
-
Urls become links, except in the text field of a submission.
")
-
-
-; 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 "Get back to work!")
- (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 noprocrast is set to
- yes, you'll be limited to sessions of maxvisit
- minutes, with minaway 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)))))))
-
-
diff --git a/lib/prompt.arc b/lib/prompt.arc
deleted file mode 100644
index af34e53..0000000
--- a/lib/prompt.arc
+++ /dev/null
@@ -1,119 +0,0 @@
-; Prompt: Web-based programming application. 4 Aug 06.
-
-(= appdir* "arc/apps/")
-
-(defop prompt req
- (let user (get-user req)
- (if (admin user)
- (prompt-page user)
- (pr "Sorry."))))
-
-(def prompt-page (user . msg)
- (ensure-dir appdir*)
- (ensure-dir (string appdir* user))
- (whitepage
- (prbold "Prompt")
- (hspace 20)
- (pr user " | ")
- (link "logout")
- (when msg (hspace 10) (apply pr msg))
- (br2)
- (tag (table border 0 cellspacing 10)
- (each app (dir (+ appdir* user))
- (tr (td app)
- (td (ulink user 'edit (edit-app user app)))
- (td (ulink user 'run (run-app user app)))
- (td (hspace 40)
- (ulink user 'delete (rem-app user app))))))
- (br2)
- (aform (fn (req)
- (when-umatch user req
- (aif (goodname (arg req "app"))
- (edit-app user it)
- (prompt-page user "Bad name."))))
- (tab (row "name:" (input "app") (submit "create app"))))))
-
-(def app-path (user app)
- (and user app (+ appdir* user "/" app)))
-
-(def read-app (user app)
- (aand (app-path user app)
- (file-exists it)
- (readfile it)))
-
-(def write-app (user app exprs)
- (awhen (app-path user app)
- (w/outfile o it
- (each e exprs (write e o)))))
-
-(def rem-app (user app)
- (let file (app-path user app)
- (if (file-exists file)
- (do (rmfile (app-path user app))
- (prompt-page user "Program " app " deleted."))
- (prompt-page user "No such app."))))
-
-(def edit-app (user app)
- (whitepage
- (pr "user: " user " app: " app)
- (br2)
- (aform (fn (req)
- (let u2 (get-user req)
- (if (is u2 user)
- (do (when (is (arg req "cmd") "save")
- (write-app user app (readall (arg req "exprs"))))
- (prompt-page user))
- (login-page 'both nil
- (fn (u ip) (prompt-page u))))))
- (textarea "exprs" 10 82
- (pprcode (read-app user app)))
- (br2)
- (buts 'cmd "save" "cancel"))))
-
-(def pprcode (exprs)
- (each e exprs
- (ppr e)
- (pr "\n\n")))
-
-(def view-app (user app)
- (whitepage
- (pr "user: " user " app: " app)
- (br2)
- (tag xmp (pprcode (read-app user app)))))
-
-(def run-app (user app)
- (let exprs (read-app user app)
- (if exprs
- (on-err (fn (c) (pr "Error: " (details c)))
- (fn () (map eval exprs)))
- (prompt-page user "Error: No application " app " for user " user))))
-
-(wipe repl-history*)
-
-(defop repl req
- (if (admin (get-user req))
- (replpage req)
- (pr "Sorry.")))
-
-(def replpage (req)
- (whitepage
- (repl (readall (or (arg req "expr") "")) "repl")))
-
-(def repl (exprs url)
- (each expr exprs
- (on-err (fn (c) (push (list expr c t) repl-history*))
- (fn ()
- (= that (eval expr) thatexpr expr)
- (push (list expr that) repl-history*))))
- (form url
- (textarea "expr" 8 60)
- (sp)
- (submit))
- (tag xmp
- (each (expr val err) (firstn 20 repl-history*)
- (pr "> ")
- (ppr expr)
- (prn)
- (prn (if err "Error: " "")
- (ellipsize (tostring (write val)) 800)))))
-