@@ -3,12 +3,11 @@ (module ac mzscheme (provide (all-defined)) -; uncomment the following require for mzscheme-4.x -; much of Arc will work, but not mutable pairs. -; (require rnrs/mutable-pairs-6) (require (lib "port.ss")) (require (lib "process.ss")) (require (lib "pretty.ss")) +(require (lib "foreign.ss")) +(unsafe!) ; compile an Arc expression into a Scheme expression, ; both represented as s-expressions. @@ -68,7 +67,7 @@ (and (>= i 0) (or (let ((c (string-ref string i))) (or (eqv? c #\:) (eqv? c #\~) - (eqv? c #\+) + (eqv? c #\&) ;(eqv? c #\_) (eqv? c #\.) (eqv? c #\!))) (has-ssyntax-char? string (- i 1))))) @@ -83,15 +82,15 @@ ; because then _!foo becomes a function. Maybe use <>. For now ; leave this off and see how often it would have been useful. -; Might want to make ~ have less precedence than +, because -; ~foo+bar prob should mean (andf (complement foo) bar), not +; Might want to make ~ have less precedence than &, because +; ~foo&bar prob should mean (andf (complement foo) bar), not ; (complement (andf foo bar)). (define (expand-ssyntax sym) ((cond ((or (insym? #\: sym) (insym? #\~ sym)) expand-compose) - ((insym? #\+ sym) expand-and) - ; ((insym? #\_ sym) expand-curry) ((or (insym? #\. sym) (insym? #\! sym)) expand-sexpr) + ((insym? #\& sym) expand-and) + ; ((insym? #\_ sym) expand-curry) (#t (error "Unknown ssyntax" sym))) sym)) @@ -113,7 +112,7 @@ (define (expand-and sym) (let ((elts (map chars->value - (tokens (lambda (c) (eqv? c #\+)) + (tokens (lambda (c) (eqv? c #\&)) (symbol->chars sym) '() '() @@ -238,9 +237,18 @@ ((and (pair? x) (eqv? (car x) 'quasiquote)) (list 'quasiquote (ac-qq1 (+ level 1) (cadr x) env))) ((pair? x) - (map (lambda (x) (ac-qq1 level x env)) x)) + (imap (lambda (x) (ac-qq1 level x env)) x)) (#t x))) +; like map, but don't demand '()-terminated list + +(define (imap f l) + (cond ((pair? l) + (cons (f (car l)) (imap f (cdr l)))) + ((null? l) + '()) + (#t (f l)))) + ; (if) -> nil ; (if x) -> x ; (if t a ...) -> a @@ -815,6 +823,8 @@ ; (type nil) -> sym +(define (exint? x) (and (integer? x) (exact? x))) + (define (ar-type x) (cond ((ar-tagged? x) (vector-ref x 1)) ((pair? x) 'cons) @@ -823,7 +833,7 @@ ((procedure? x) 'fn) ((char? x) 'char) ((string? x) 'string) - ((integer? x) 'int) + ((exint? x) 'int) ((number? x) 'num) ; unsure about this ((hash-table? x) 'table) ((output-port? x) 'output) @@ -950,7 +960,7 @@ ((string) (string x)) ((sym) (string->symbol (string x))) (else (err "Can't coerce" x type)))) - ((integer? x) (case type + ((exint? x) (case type ((num) x) ((char) (ascii->char x)) ((string) (apply number->string x args)) @@ -1008,6 +1018,11 @@ (let-values (((us them) (tcp-addresses out))) them)))))))) +; allow Arc to give up root privileges after it +; calls open-socket. thanks, Eli! +(define setuid (get-ffi-obj 'setuid #f (_fun _int -> _int))) +(xdef setuid setuid) + (xdef new-thread thread) (xdef kill-thread kill-thread) (xdef break-thread break-thread) @@ -1216,15 +1231,52 @@ (xdef scar (lambda (x val) (if (string? x) (string-set! x 0 val) - (set-car! x val)) + (x-set-car! x val)) val)) (xdef scdr (lambda (x val) (if (string? x) (err "Can't set cdr of a string" x) - (set-cdr! x val)) + (x-set-cdr! x val)) val)) +; decide at run-time whether the underlying mzscheme supports +; set-car! and set-cdr!, since I can't figure out how to do it +; at compile time. + +(define (x-set-car! p v) + (let ((fn (namespace-variable-value 'set-car! #t (lambda () #f)))) + (if (procedure? fn) + (fn p v) + (n-set-car! p v)))) + +(define (x-set-cdr! p v) + (let ((fn (namespace-variable-value 'set-cdr! #t (lambda () #f)))) + (if (procedure? fn) + (fn p v) + (n-set-cdr! p v)))) + +; Eli's code to modify mzscheme-4's immutable pairs. + +;; to avoid a malloc on every call, reuse a single pointer, but make +;; it thread-local to avoid races +(define ptr (make-thread-cell #f)) +(define (get-ptr) + (or (thread-cell-ref ptr) + (let ([p (malloc _scheme 1)]) (thread-cell-set! ptr p) p))) + +;; set a pointer to the cons cell, then dereference it as a pointer, +;; and bang the new value in the given offset +(define (set-ca/dr! offset who p x) + (if (pair? p) + (let ([p* (get-ptr)]) + (ptr-set! p* _scheme p) + (ptr-set! (ptr-ref p* _pointer 0) _scheme offset x)) + (raise-type-error who "pair" p))) + +(define (n-set-car! p x) (set-ca/dr! 1 'set-car! p x)) +(define (n-set-cdr! p x) (set-ca/dr! 2 'set-cdr! p x)) + ; When and if cdr of a string returned an actual (eq) tail, could ; say (if (string? x) (string-replace! x val 1) ...) in scdr, but ; for now would be misleading to allow this, because fails for cddr. @@ -1249,7 +1301,7 @@ val)) (define (nth-set! lst n val) - (set-car! (list-tail lst n) val)) + (x-set-car! (list-tail lst n) val)) ; rewrite to pass a (true) gensym instead of #f in case var bound to #f @@ -1264,8 +1316,9 @@ (xdef trunc (lambda (x) (inexact->exact (truncate x)))) -(xdef exact (lambda (x) - (tnil (and (integer? x) (exact? x))))) +; bad name + +(xdef exact (lambda (x) (tnil (exint? x)))) (xdef msec current-milliseconds) (xdef current-process-milliseconds current-process-milliseconds) ac.scm @@ -373,28 +373,42 @@ date (or (errsafe (parse-date str)) fail) (err "unknown readvar type" typ))) -(= fail* (uniq)) +; dates should be tagged date, and just redefine < + +(def varcompare (typ) + (if (in typ 'syms 'sexpr 'users 'toks 'bigtoks 'lines 'hexcol) + (fn (x y) (> (len x) (len y))) + (is typ 'date) + (fn (x y) + (or (no y) (and x (date< x y)))) + (fn (x y) + (or (empty y) (and (~empty x) (< x y)))))) + + +; (= fail* (uniq)) + +(def fail* ()) ; coudn't possibly come back from a form ; Takes a list of fields of the form (type label value view modify) and ; a fn f and generates a form such that when submitted (f label newval) ; will be called for each valid value. Finally done is called. (def vars-form (user fields f done (o button "update") (o lasts)) - (timed-aform lasts - (if (all [no (_ 4)] fields) - (fn (req)) - (fn (req) - (when-umatch user req - (each (k v) req!args - (let name (sym k) - (awhen (find [is (cadr _) name] fields) - ; added sho to fix bug - (let (typ id val sho mod) it - (when (and mod v) - (let newval (readvar typ v fail*) - (unless (is newval fail*) - (f name newval)))))))) - (done)))) + (taform lasts + (if (all [no (_ 4)] fields) + (fn (req)) + (fn (req) + (when-umatch user req + (each (k v) req!args + (let name (sym k) + (awhen (find [is (cadr _) name] fields) + ; added sho to fix bug + (let (typ id val sho mod) it + (when (and mod v) + (let newval (readvar typ v fail*) + (unless (is newval fail*) + (f name newval)))))))) + (done)))) (tab (showvars fields)) (unless (all [no (_ 4)] fields) ; no modifiable fields @@ -415,7 +429,7 @@ ; http://daringfireball.net/projects/markdown/syntax (def md-from-form (str (o nolinks)) - (markdown (trim (rem #\return (esc<>& str)) 'end) 60 nolinks)) + (markdown (trim (rem #\return (esc-tags str)) 'end) 60 nolinks)) (def markdown (s (o maxurl) (o nolinks)) (let ital nil @@ -490,7 +504,7 @@ ; Note that > immediately after a url (http://foo.com>) will cause ; an odd result, because the > gets escaped to something beginning ; with &, which is treated as part of the url. Perhaps the answer -; is just to esc<>& after markdown instead of before. +; is just to esc-tags after markdown instead of before. ; Treats a delimiter as part of a url if it is (a) an open delimiter ; not followed by whitespace or eos, or (b) a close delimiter @@ -573,9 +587,9 @@ (if (in cleanlabel "am" "midnight") 0 12) - (is cleanlabel "pm") - (+ h 12) - h) + (is cleanlabel "am") + h + (+ h 12)) 60) m)))) app.arc @@ -204,7 +204,8 @@ (def empty (seq) (or (no seq) - (and (no (acons seq)) (is (len seq) 0)))) + (and (or (is (type seq) 'string) (is (type seq) 'table)) + (is (len seq) 0)))) (def reclist (f xs) (and xs (or (f xs) (reclist f (cdr xs))))) @@ -1233,7 +1234,7 @@ (def inst (tem . args) (let x (table) - (each (k v) (templates* tem) + (each (k v) (if (acons tem) tem (templates* tem)) (unless (no v) (= (x k) (v)))) (each (k v) (pair args) (= (x k) v)) @@ -1248,7 +1249,7 @@ ; Note: discards fields not defined by the template. (def templatize (tem raw) - (with (x (inst tem) fields (templates* tem)) + (with (x (inst tem) fields (if (acons tem) tem (templates* tem))) (each (k v) raw (when (assoc k fields) (= (x k) v))) arc.arc @@ -1,8 +1,8 @@ To run News: -tar xvf arc3.tar +tar xvf arc3.1.tar -cd arc3 +cd arc3.1 mkdir arc how-to-run-news @@ -61,6 +61,9 @@ (def opsel (key val) `(if ,val (pr " selected"))) +(def opcheck (key val) + `(if ,val (pr " checked"))) + (def opesc (key val) `(awhen ,val (pr ,(string " " key "=\"")) @@ -106,8 +109,9 @@ (attribute input size opnum) (attribute input type opsym) (attribute input value opesc) -(attribute option selected opsel) +(attribute input checked opcheck) (attribute select name opstring) +(attribute option selected opsel) (attribute table bgcolor opcolor) (attribute table border opnum) (attribute table cellpadding opnum) @@ -343,7 +347,7 @@ #\& "&#38;" c))))) -(def esc<>& (str) +(def esc-tags (str) (tostring (each c str (pr (case c #\< "&#60;" html.arc @@ -191,7 +191,7 @@ (def load-item (id) (let i (temload 'item (+ storydir* id)) (= (items* id) i) - (awhen (and (astory+live i) (check i!url ~blank)) + (awhen (and (astory&live i) (check i!url ~blank)) (register-url i it)) i)) @@ -222,7 +222,7 @@ ; because people try e.g. item?id=363/blank.php (def safe-item (id) - (ok-id+item (if (isa id 'string) (saferead id) id))) + (ok-id&item (if (isa id 'string) (saferead id) id))) (def ok-id (id) (and (exact id) (<= 1 id maxid*))) @@ -254,7 +254,7 @@ ,@body))))) (def loaded-items (test) - (accum a (each-loaded-item i (test+a i)))) + (accum a (each-loaded-item i (test&a i)))) (def newslog args (apply srvlog 'news args)) @@ -271,7 +271,7 @@ (* (/ (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)) 1 + (if (no (in s!type 'story 'poll)) .5 (blank s!url) nourl-factor* (lightweight s) (min lightweight-factor* (contro-factor s)) @@ -287,7 +287,8 @@ (disktable lightweights* (+ newsdir* "lightweights")) (def lightweight (s) - (or (mem 'rally s!keys) ; title is a rallying cry + (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))) @@ -719,13 +720,13 @@ function vote(node) { (if (profile subject) (do (killallby subject) (submitted-page user subject)) - (admin+newsadmin-page user)))) + (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))) + (admin&newsadmin-page user))) (single-input "" 'ip 20 "ban ip")))) @@ -866,13 +867,14 @@ function vote(node) { (bestn n (compare > realscore) (visible user stories*))) -(newsop noobs () (noobpage user)) +(newsop noobstories () (noobspage user stories*)) +(newsop noobcomments () (noobspage user comments*)) -(def noobpage (user) - (listpage user (msec) (noobstories user maxend*) "noobs" "New Accounts")) +(def noobspage (user source) + (listpage user (msec) (noobs user maxend* source) "noobs" "New Accounts")) -(def noobstories (user n) - (retrieve n [and (cansee user _) (bynoob _)] stories*)) +(def noobs (user n source) + (retrieve n [and (cansee user _) (bynoob _)] source)) (def bynoob (i) (< (- (user-age i!by) (item-age i)) 2880)) @@ -894,7 +896,8 @@ function vote(node) { (row (link "best") "Highest voted recent links.") (row (link "active") "Most active current discussions.") (row (link "bestcomments") "Highest voted recent comments.") - (row (link "noobs") "Submissions from new accounts.") + (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))) @@ -1035,7 +1038,7 @@ function vote(node) { (when (and i!deleted (admin user)) (pr " [deleted] "))) -(= downvote-threshold* 100 downvote-time* 1440) +(= downvote-threshold* 200 downvote-time* 1440) (= votewid* 14) @@ -1079,14 +1082,14 @@ function vote(node) { (if user (+ "&by=" user "&auth=" (user->cookie* user))) "&whence=" (urlencode whence))) -(= lowest-score* -8) +(= 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) + (news-type&live i) (or (is dir 'up) (> i!score lowest-score*)) (no ((votes user) i!id)) (or (is dir 'up) @@ -1205,6 +1208,8 @@ function vote(node) { (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 @@ -1218,6 +1223,7 @@ function vote(node) { (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) @@ -1364,7 +1370,7 @@ function vote(node) { ; canvote protects against sockpuppet downvote of comments (when (and (is dir 'up) (possible-sockpuppet user)) (++ i!sockvotes)) - (metastory+adjust-rank i) + (metastory&adjust-rank i) (unless (or (author user i) (and (is ip i!ip) (~editor user)) (is i!type 'pollopt)) @@ -1528,8 +1534,8 @@ function vote(node) { (< (karma user) new-karma-threshold*)) (len> (recent-items [or (author user _) (is _!ip ip)] 180) (if (is kind 'story) - (if (ignored user) 0 1) - (if (ignored user) 1 10))))) + (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. @@ -1553,18 +1559,17 @@ function vote(node) { (if (isa (saferead (car toks)) 'int) (tostring (prall toks "" ".")) (let (t1 t2 t3 . rest) toks - (if (and t3 (or (mem t1 multi-tld-countries*) - (mem t2 long-domains*))) + (if (and (~in t3 nil "www") + (or (mem t1 multi-tld-countries*) + (mem t2 long-domains*))) (+ t3 "." t2 "." t1) (and t2 (+ t2 "." t1)))))))) -; Minor bug: can have both google.at and google.co.at. Same for jp. - (= 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" "blog-city" "supersized" + "weebly" "posterous" "blog-city" "supersized" "dreamhosters" ; "sampasite" "multiply" "wetpaint" ; all spam, just ban "eurekster" "blogsome" "edogo" "blog" "com")) @@ -1823,7 +1828,7 @@ function vote(node) { (= commentable-threshold* (* 60 24 45)) (def comments-active (i) - (and (live+commentable i) + (and (live&commentable i) (live (superparent i)) (or (< (item-age i) commentable-threshold*) (mem 'commentable i!keys)))) @@ -1932,7 +1937,7 @@ function vote(node) { (= (i name) val))) (fn () (if (admin user) (pushnew 'locked i!keys)) (save-item i) - (metastory+adjust-rank i) + (metastory&adjust-rank i) (wipe (comment-cache* i!id)) (edit-page user i))) (hook 'edit user i)))) @@ -1992,11 +1997,13 @@ function vote(node) { (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*) - (when (or (ignored user) (< (karma user) comment-threshold*)) - (kill c 'ignored/karma)) + (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) news.arc @@ -11,6 +11,7 @@ (ensure-srvdirs) (map [apply new-bgthread _] pending-bgthreads*) (w/socket s port + (setuid 2) ; XXX switch from root to pg (prn "ready to serve port " port) (flushout) (= currsock* s) @@ -453,7 +454,7 @@ Connection: close")) ; Like aform except creates a fnid that will last for lasts seconds ; (unless the server is restarted). -(mac timed-aform (lasts f . body) +(mac taform (lasts f . body) (w/uniq (gl gf gi ga) `(withs (,gl ,lasts ,gf (fn (,ga) (prn) (,f ,ga))) srv.arc static/arc.png @@ -44,6 +44,15 @@ (a (cut s (+ p 1))))) (cons -1 (positions #\newline s))))) +(def slices (s test) + (accum a + ((afn ((p . ps)) + (if ps + (do (a (cut s (+ p 1) (car ps))) + (self ps)) + (a (cut s (+ p 1))))) + (cons -1 (positions test s))))) + ; > (require (lib "uri-codec.ss" "net")) ;> (form-urlencoded-decode "x%ce%bbx") ;"xλx" @@ -149,7 +158,7 @@ (def nonblank (s) (unless (blank s) s)) -(def trim (s where (o test whitec)) +(def trim (s (o where 'both) (o test whitec)) (withs (f (testify test) p1 (pos ~f s)) (if p1 strings.arc aaccf343eb29e3de884c980b26e02f5460c759a8 pg and rtm <> http://github.com/nex3/arc/commit/f01d3f9c661eed05511711a0f3388ca2a1d34fa2 f01d3f9c661eed05511711a0f3388ca2a1d34fa2 2009-08-04T14:28:48-07:00 2009-08-04T14:28:48-07:00 arc3.1.tar 50b8bcf931c4dc204f74b8721de9244ab4977056 Michael Arntzenius daekharel@gmail.com