diff options
| -rw-r--r-- | ac.scm | 1489 | ||||
| -rw-r--r-- | app.arc | 671 | ||||
| -rw-r--r-- | arc.arc | 1700 | ||||
| -rw-r--r-- | as.scm | 16 | ||||
| -rw-r--r-- | blog.arc | 95 | ||||
| -rw-r--r-- | brackets.scm | 48 | ||||
| -rw-r--r-- | code.arc | 61 | ||||
| -rw-r--r-- | copyright | 2 | ||||
| -rw-r--r-- | how-to-run-news | 44 | ||||
| -rw-r--r-- | html.arc | 415 | ||||
| -rw-r--r-- | libs.arc | 7 | ||||
| -rw-r--r-- | news.arc | 2617 | ||||
| -rw-r--r-- | pprint.arc | 80 | ||||
| -rw-r--r-- | prompt.arc | 119 | ||||
| -rw-r--r-- | srv.arc | 573 | ||||
| -rw-r--r-- | static/arc.png | bin | 0 -> 113 bytes | |||
| -rw-r--r-- | static/grayarrow.gif | bin | 0 -> 111 bytes | |||
| -rw-r--r-- | static/graydown.gif | bin | 0 -> 111 bytes | |||
| -rw-r--r-- | static/robots.txt | 0 | ||||
| -rw-r--r-- | static/s.gif | bin | 0 -> 43 bytes | |||
| -rw-r--r-- | strings.arc | 226 |
21 files changed, 8163 insertions, 0 deletions
@@ -0,0 +1,1489 @@ +; Arc Compiler. + +(module ac mzscheme + +(provide (all-defined)) +(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. +; env is a list of lexically bound variables, which we +; need in order to decide whether set should create a global. + +(define (ac s env) + (cond ((string? s) (ac-string s env)) + ((literal? s) s) + ((eqv? s 'nil) (list 'quote 'nil)) + ((ssyntax? s) (ac (expand-ssyntax s) env)) + ((symbol? s) (ac-var-ref s env)) + ((ssyntax? (xcar s)) (ac (cons (expand-ssyntax (car s)) (cdr s)) env)) + ((eq? (xcar s) 'quote) (list 'quote (ac-niltree (cadr s)))) + ((eq? (xcar s) 'quasiquote) (ac-qq (cadr s) env)) + ((eq? (xcar s) 'if) (ac-if (cdr s) env)) + ((eq? (xcar s) 'fn) (ac-fn (cadr s) (cddr s) env)) + ((eq? (xcar s) 'assign) (ac-set (cdr s) env)) + ; the next three clauses could be removed without changing semantics + ; ... except that they work for macros (so prob should do this for + ; every elt of s, not just the car) + ((eq? (xcar (xcar s)) 'compose) (ac (decompose (cdar s) (cdr s)) env)) + ((eq? (xcar (xcar s)) 'complement) + (ac (list 'no (cons (cadar s) (cdr s))) env)) + ((eq? (xcar (xcar s)) 'andf) (ac-andf s env)) + ((pair? s) (ac-call (car s) (cdr s) env)) + (#t (err "Bad object in expression" s)))) + +(define atstrings #f) + +(define (ac-string s env) + (if atstrings + (if (atpos s 0) + (ac (cons 'string (map (lambda (x) + (if (string? x) + (unescape-ats x) + x)) + (codestring s))) + env) + (unescape-ats s)) + (string-copy s))) ; avoid immutable strings + +(define (literal? x) + (or (boolean? x) + (char? x) + (string? x) + (number? x) + (eq? x '()))) + +(define (ssyntax? x) + (and (symbol? x) + (not (or (eqv? x '+) (eqv? x '++) (eqv? x '_))) + (let ((name (symbol->string x))) + (has-ssyntax-char? name (- (string-length name) 1))))) + +(define (has-ssyntax-char? string i) + (and (>= i 0) + (or (let ((c (string-ref string i))) + (or (eqv? c #\:) (eqv? c #\~) + (eqv? c #\&) + ;(eqv? c #\_) + (eqv? c #\.) (eqv? c #\!))) + (has-ssyntax-char? string (- i 1))))) + +(define (read-from-string str) + (let ((port (open-input-string str))) + (let ((val (read port))) + (close-input-port port) + val))) + +; Though graphically the right choice, can't use _ for currying +; 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 +; (complement (andf foo bar)). + +(define (expand-ssyntax sym) + ((cond ((or (insym? #\: sym) (insym? #\~ sym)) expand-compose) + ((or (insym? #\. sym) (insym? #\! sym)) expand-sexpr) + ((insym? #\& sym) expand-and) + ; ((insym? #\_ sym) expand-curry) + (#t (error "Unknown ssyntax" sym))) + sym)) + +(define (expand-compose sym) + (let ((elts (map (lambda (tok) + (if (eqv? (car tok) #\~) + (if (null? (cdr tok)) + 'no + `(complement ,(chars->value (cdr tok)))) + (chars->value tok))) + (tokens (lambda (c) (eqv? c #\:)) + (symbol->chars sym) + '() + '() + #f)))) + (if (null? (cdr elts)) + (car elts) + (cons 'compose elts)))) + +(define (expand-and sym) + (let ((elts (map chars->value + (tokens (lambda (c) (eqv? c #\&)) + (symbol->chars sym) + '() + '() + #f)))) + (if (null? (cdr elts)) + (car elts) + (cons 'andf elts)))) + +; How to include quoted arguments? Can't treat all as quoted, because +; never want to quote fn given as first. Do we want to allow quote chars +; within symbols? Could be ugly. + +; If release, fix the fact that this simply uses v0... as vars. Should +; make these vars gensyms. + +(define (expand-curry sym) + (let ((expr (exc (map (lambda (x) + (if (pair? x) (chars->value x) x)) + (tokens (lambda (c) (eqv? c #\_)) + (symbol->chars sym) + '() + '() + #t)) + 0))) + (list 'fn + (keep (lambda (s) + (and (symbol? s) + (eqv? (string-ref (symbol->string s) 0) + #\v))) + expr) + expr))) + +(define (keep f xs) + (cond ((null? xs) '()) + ((f (car xs)) (cons (car xs) (keep f (cdr xs)))) + (#t (keep f (cdr xs))))) + +(define (exc elts n) + (cond ((null? elts) + '()) + ((eqv? (car elts) #\_) + (cons (string->symbol (string-append "v" (number->string n))) + (exc (cdr elts) (+ n 1)))) + (#t + (cons (car elts) (exc (cdr elts) n))))) + +(define (expand-sexpr sym) + (build-sexpr (reverse (tokens (lambda (c) (or (eqv? c #\.) (eqv? c #\!))) + (symbol->chars sym) + '() + '() + #t)) + sym)) + +(define (build-sexpr toks orig) + (cond ((null? toks) + 'get) + ((null? (cdr toks)) + (chars->value (car toks))) + (#t + (list (build-sexpr (cddr toks) orig) + (if (eqv? (cadr toks) #\!) + (list 'quote (chars->value (car toks))) + (if (or (eqv? (car toks) #\.) (eqv? (car toks) #\!)) + (err "Bad ssyntax" orig) + (chars->value (car toks)))))))) + +(define (insym? char sym) (member char (symbol->chars sym))) + +(define (symbol->chars x) (string->list (symbol->string x))) + +(define (chars->value chars) (read-from-string (list->string chars))) + +(define (tokens test source token acc keepsep?) + (cond ((null? source) + (reverse (if (pair? token) + (cons (reverse token) acc) + acc))) + ((test (car source)) + (tokens test + (cdr source) + '() + (let ((rec (if (null? token) + acc + (cons (reverse token) acc)))) + (if keepsep? + (cons (car source) rec) + rec)) + keepsep?)) + (#t + (tokens test + (cdr source) + (cons (car source) token) + acc + keepsep?)))) + +(define (ac-global-name s) + (string->symbol (string-append "_" (symbol->string s)))) + +(define (ac-var-ref s env) + (if (lex? s env) + s + (ac-global-name s))) + +; quasiquote + +(define (ac-qq args env) + (list 'quasiquote (ac-qq1 1 args env))) + +; process the argument of a quasiquote. keep track of +; depth of nesting. handle unquote only at top level (level = 1). +; complete form, e.g. x or (fn x) or (unquote (fn x)) + +(define (ac-qq1 level x env) + (cond ((= level 0) + (ac x env)) + ((and (pair? x) (eqv? (car x) 'unquote)) + (list 'unquote (ac-qq1 (- level 1) (cadr x) env))) + ((and (pair? x) (eqv? (car x) 'unquote-splicing) (= level 1)) + (list 'unquote-splicing + (list 'ar-nil-terminate (ac-qq1 (- level 1) (cadr x) env)))) + ((and (pair? x) (eqv? (car x) 'quasiquote)) + (list 'quasiquote (ac-qq1 (+ level 1) (cadr x) env))) + ((pair? 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 +; (if nil a b) -> b +; (if nil a b c) -> (if b c) + +(define (ac-if args env) + (cond ((null? args) ''nil) + ((null? (cdr args)) (ac (car args) env)) + (#t `(if (not (ar-false? ,(ac (car args) env))) + ,(ac (cadr args) env) + ,(ac-if (cddr args) env))))) + +(define (ac-dbname! name env) + (if (symbol? name) + (cons (list name) env) + env)) + +(define (ac-dbname env) + (cond ((null? env) #f) + ((pair? (car env)) (caar env)) + (#t (ac-dbname (cdr env))))) + +; translate fn directly into a lambda if it has ordinary +; parameters, otherwise use a rest parameter and parse it. + +(define (ac-fn args body env) + (if (ac-complex-args? args) + (ac-complex-fn args body env) + (ac-nameit + (ac-dbname env) + `(lambda ,(let ((a (ac-denil args))) (if (eqv? a 'nil) '() a)) + ,@(ac-body* body (append (ac-arglist args) env)))))) + +; does an fn arg list use optional parameters or destructuring? +; a rest parameter is not complex + +(define (ac-complex-args? args) + (cond ((eqv? args '()) #f) + ((symbol? args) #f) + ((and (pair? args) (symbol? (car args))) + (ac-complex-args? (cdr args))) + (#t #t))) + +; translate a fn with optional or destructuring args +; (fn (x (o y x) (o z 21) (x1 x2) . rest) ...) +; arguments in top-level list are mandatory (unless optional), +; but it's OK for parts of a list you're destructuring to +; be missing. + +(define (ac-complex-fn args body env) + (let* ((ra (ar-gensym)) + (z (ac-complex-args args env ra #t))) + `(lambda ,ra + (let* ,z + ,@(ac-body* body (append (ac-complex-getargs z) env)))))) + +; returns a list of two-element lists, first is variable name, +; second is (compiled) expression. to be used in a let. +; caller should extract variables and add to env. +; ra is the rest argument to the fn. +; is-params indicates that args are function arguments +; (not destructuring), so they must be passed or be optional. + +(define (ac-complex-args args env ra is-params) + (cond ((or (eqv? args '()) (eqv? args 'nil)) '()) + ((symbol? args) (list (list args ra))) + ((pair? args) + (let* ((x (if (and (pair? (car args)) (eqv? (caar args) 'o)) + (ac-complex-opt (cadar args) + (if (pair? (cddar args)) + (caddar args) + 'nil) + env + ra) + (ac-complex-args + (car args) + env + (if is-params + `(car ,ra) + `(ar-xcar ,ra)) + #f))) + (xa (ac-complex-getargs x))) + (append x (ac-complex-args (cdr args) + (append xa env) + `(ar-xcdr ,ra) + is-params)))) + (#t (err "Can't understand fn arg list" args)))) + +; (car ra) is the argument +; so it's not present if ra is nil or '() + +(define (ac-complex-opt var expr env ra) + (list (list var `(if (pair? ,ra) (car ,ra) ,(ac expr env))))) + +; extract list of variables from list of two-element lists. + +(define (ac-complex-getargs a) + (map (lambda (x) (car x)) a)) + +; (a b . c) -> (a b c) +; a -> (a) + +(define (ac-arglist a) + (cond ((null? a) '()) + ((symbol? a) (list a)) + ((symbol? (cdr a)) (list (car a) (cdr a))) + (#t (cons (car a) (ac-arglist (cdr a)))))) + +(define (ac-body body env) + (map (lambda (x) (ac x env)) body)) + +; like ac-body, but spits out a nil expression if empty + +(define (ac-body* body env) + (if (null? body) + (list (list 'quote 'nil)) + (ac-body body env))) + +; (set v1 expr1 v2 expr2 ...) + +(define (ac-set x env) + `(begin ,@(ac-setn x env))) + +(define (ac-setn x env) + (if (null? x) + '() + (cons (ac-set1 (ac-macex (car x)) (cadr x) env) + (ac-setn (cddr x) env)))) + +; trick to tell Scheme the name of something, so Scheme +; debugging and profiling make more sense. + +(define (ac-nameit name v) + (if (symbol? name) + (let ((n (string->symbol (string-append " " (symbol->string name))))) + (list 'let `((,n ,v)) n)) + v)) + +; = replaced by set, which is only for vars +; = now defined in arc (is it?) +; name is to cause fns to have their arc names for debugging + +(define (ac-set1 a b1 env) + (if (symbol? a) + (let ((b (ac b1 (ac-dbname! a env)))) + (list 'let `((zz ,b)) + (cond ((eqv? a 'nil) (err "Can't rebind nil")) + ((eqv? a 't) (err "Can't rebind t")) + ((lex? a env) `(set! ,a zz)) + (#t `(namespace-set-variable-value! ',(ac-global-name a) + zz))) + 'zz)) + (err "First arg to set must be a symbol" a))) + +; given a list of Arc expressions, return a list of Scheme expressions. +; for compiling passed arguments. + +(define (ac-args names exprs env) + (if (null? exprs) + '() + (cons (ac (car exprs) + (ac-dbname! (if (pair? names) (car names) #f) env)) + (ac-args (if (pair? names) (cdr names) '()) + (cdr exprs) + env)))) + +; generate special fast code for ordinary two-operand +; calls to the following functions. this is to avoid +; calling e.g. ar-is with its &rest and apply. + +(define ac-binaries + '((is ar-is2) + (< ar-<2) + (> ar->2) + (+ ar-+2))) + +; (foo bar) where foo is a global variable bound to a procedure. + +(define (ac-global-call fn args env) + (cond ((and (assoc fn ac-binaries) (= (length args) 2)) + `(,(cadr (assoc fn ac-binaries)) ,@(ac-args '() args env))) + (#t + `(,(ac-global-name fn) ,@(ac-args '() args env))))) + +; compile a function call +; special cases for speed, to avoid compiled output like +; (ar-apply _pr (list 1 2)) +; which results in 1/2 the CPU time going to GC. Instead: +; (ar-funcall2 _pr 1 2) +; and for (foo bar), if foo is a reference to a global variable, +; and it's bound to a function, generate (foo bar) instead of +; (ar-funcall1 foo bar) + +(define direct-calls #f) + +(define (ac-call fn args env) + (let ((macfn (ac-macro? fn))) + (cond (macfn + (ac-mac-call macfn args env)) + ((and (pair? fn) (eqv? (car fn) 'fn)) + `(,(ac fn env) ,@(ac-args (cadr fn) args env))) + ((and direct-calls (symbol? fn) (not (lex? fn env)) (bound? fn) + (procedure? (namespace-variable-value (ac-global-name fn)))) + (ac-global-call fn args env)) + ((= (length args) 0) + `(ar-funcall0 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args))) + ((= (length args) 1) + `(ar-funcall1 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args))) + ((= (length args) 2) + `(ar-funcall2 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args))) + ((= (length args) 3) + `(ar-funcall3 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args))) + ((= (length args) 4) + `(ar-funcall4 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args))) + (#t + `(ar-apply ,(ac fn env) + (list ,@(map (lambda (x) (ac x env)) args))))))) + +(define (ac-mac-call m args env) + (let ((x1 (apply m (map ac-niltree args)))) + (let ((x2 (ac (ac-denil x1) env))) + x2))) + +; returns #f or the macro function + +(define (ac-macro? fn) + (if (symbol? fn) + (let ((v (namespace-variable-value (ac-global-name fn) + #t + (lambda () #f)))) + (if (and v + (ar-tagged? v) + (eq? (ar-type v) 'mac)) + (ar-rep v) + #f)) + #f)) + +; macroexpand the outer call of a form as much as possible + +(define (ac-macex e . once) + (if (pair? e) + (let ((m (ac-macro? (car e)))) + (if m + (let ((expansion (ac-denil (apply m (map ac-niltree (cdr e)))))) + (if (null? once) (ac-macex expansion) expansion)) + e)) + e)) + +; macros return Arc lists, ending with NIL. +; but the Arc compiler expects Scheme lists, ending with '(). +; what to do with (is x nil . nil) ? +; the first nil ought to be replaced with 'NIL +; the second with '() +; so the rule is: NIL in the car -> 'NIL, NIL in the cdr -> '(). +; NIL by itself -> NIL + +(define (ac-denil x) + (cond ((pair? x) (cons (ac-denil-car (car x)) (ac-denil-cdr (cdr x)))) + (#t x))) + +(define (ac-denil-car x) + (if (eq? x 'nil) + 'nil + (ac-denil x))) + +(define (ac-denil-cdr x) + (if (eq? x 'nil) + '() + (ac-denil x))) + +; is v lexically bound? + +(define (lex? v env) + (memq v env)) + +(define (xcar x) + (and (pair? x) (car x))) + +; #f and '() -> nil for a whole quoted list/tree. + +; Arc primitives written in Scheme should look like: + +; (xdef foo (lambda (lst) +; (ac-niltree (scheme-foo (ar-nil-terminate lst))))) + +; That is, Arc lists are NIL-terminated. When calling a Scheme +; function that treats an argument as a list, call ar-nil-terminate +; to change NIL to '(). When returning any data created by Scheme +; to Arc, call ac-niltree to turn all '() into NIL. +; (hash-table-get doesn't use its argument as a list, so it doesn't +; need ar-nil-terminate). + +(define (ac-niltree x) + (cond ((pair? x) (cons (ac-niltree (car x)) (ac-niltree (cdr x)))) + ((or (eq? x #f) (eq? x '())) 'nil) + (#t x))) + +; The next two are optimizations, except work for macros. + +(define (decompose fns args) + (cond ((null? fns) `((fn vals (car vals)) ,@args)) + ((null? (cdr fns)) (cons (car fns) args)) + (#t (list (car fns) (decompose (cdr fns) args))))) + +(define (ac-andf s env) + (ac (let ((gs (map (lambda (x) (ar-gensym)) (cdr s)))) + `((fn ,gs + (and ,@(map (lambda (f) `(,f ,@gs)) + (cdar s)))) + ,@(cdr s))) + env)) + +(define err error) + +; run-time primitive procedures + +;(define (xdef a b) +; (namespace-set-variable-value! (ac-global-name a) b) +; b) + +(define-syntax xdef + (syntax-rules () + ((xxdef a b) + (let ((nm (ac-global-name 'a)) + (a b)) + (namespace-set-variable-value! nm a) + a)))) + +(define fn-signatures (make-hash-table 'equal)) + +; This is a replacement for xdef that stores opeator signatures. +; Haven't started using it yet. + +(define (odef a parms b) + (namespace-set-variable-value! (ac-global-name a) b) + (hash-table-put! fn-signatures a (list parms)) + b) + +(xdef sig fn-signatures) + +; versions of car and cdr for parsing arguments for optional +; parameters, that yield nil for nil. maybe we should use +; full Arc car and cdr, so we can destructure more things + +(define (ar-xcar x) + (if (or (eqv? x 'nil) (eqv? x '())) + 'nil + (car x))) + +(define (ar-xcdr x) + (if (or (eqv? x 'nil) (eqv? x '())) + 'nil + (cdr x))) + +; convert #f from a Scheme predicate to NIL. + +(define (ar-nill x) + (if (or (eq? x '()) (eq? x #f)) + 'nil + x)) + +; definition of falseness for Arc if. +; must include '() since sometimes Arc functions see +; Scheme lists (e.g. . body of a macro). + +(define (ar-false? x) + (or (eq? x 'nil) (eq? x '()) (eq? x #f))) + +; call a function or perform an array ref, hash ref, &c + +; Non-fn constants in functional position are valuable real estate, so +; should figure out the best way to exploit it. What could (1 foo) or +; ('a foo) mean? Maybe it should mean currying. + +; For now the way to make the default val of a hash table be other than +; nil is to supply the val when doing the lookup. Later may also let +; defaults be supplied as an arg to table. To implement this, need: an +; eq table within scheme mapping tables to defaults, and to adapt the +; code in arc.arc that reads and writes tables to read and write their +; default vals with them. To make compatible with existing written tables, +; just use an atom or 3-elt list to keep the default. + +(define (ar-apply fn args) + (cond ((procedure? fn) + (apply fn args)) + ((pair? fn) + (list-ref fn (car args))) + ((string? fn) + (string-ref fn (car args))) + ((hash-table? fn) + (ar-nill (hash-table-get fn + (car args) + (if (pair? (cdr args)) (cadr args) #f)))) +; experiment: means e.g. [1] is a constant fn +; ((or (number? fn) (symbol? fn)) fn) +; another possibility: constant in functional pos means it gets +; passed to the first arg, i.e. ('kids item) means (item 'kids). + (#t (err "Function call on inappropriate object" fn args)))) + +(xdef apply (lambda (fn . args) + (ar-apply fn (ar-apply-args args)))) + +; special cases of ar-apply for speed and to avoid consing arg lists + +(define (ar-funcall0 fn) + (if (procedure? fn) + (fn) + (ar-apply fn (list)))) + +(define (ar-funcall1 fn arg1) + (if (procedure? fn) + (fn arg1) + (ar-apply fn (list arg1)))) + +(define (ar-funcall2 fn arg1 arg2) + (if (procedure? fn) + (fn arg1 arg2) + (ar-apply fn (list arg1 arg2)))) + +(define (ar-funcall3 fn arg1 arg2 arg3) + (if (procedure? fn) + (fn arg1 arg2 arg3) + (ar-apply fn (list arg1 arg2 arg3)))) + +(define (ar-funcall4 fn arg1 arg2 arg3 arg4) + (if (procedure? fn) + (fn arg1 arg2 arg3 arg4) + (ar-apply fn (list arg1 arg2 arg3 arg4)))) + +; replace the nil at the end of a list with a '() + +(define (ar-nil-terminate l) + (if (or (eqv? l '()) (eqv? l 'nil)) + '() + (cons (car l) (ar-nil-terminate (cdr l))))) + +; turn the arguments to Arc apply into a list. +; if you call (apply fn 1 2 '(3 4)) +; then args is '(1 2 (3 4 . nil) . ()) +; that is, the main list is a scheme list. +; and we should return '(1 2 3 4 . ()) +; was once (apply apply list (ac-denil args)) +; but that didn't work for (apply fn nil) + +(define (ar-apply-args args) + (cond ((null? args) '()) + ((null? (cdr args)) (ar-nil-terminate (car args))) + (#t (cons (car args) (ar-apply-args (cdr args)))))) + + + + + +(xdef cons cons) + +(xdef car (lambda (x) + (cond ((pair? x) (car x)) + ((eqv? x 'nil) 'nil) + ((eqv? x '()) 'nil) + (#t (err "Can't take car of" x))))) + +(xdef cdr (lambda (x) + (cond ((pair? x) (cdr x)) + ((eqv? x 'nil) 'nil) + ((eqv? x '()) 'nil) + (#t (err "Can't take cdr of" x))))) + +(define (tnil x) (if x 't 'nil)) + +; (pairwise pred '(a b c d)) => +; (and (pred a b) (pred b c) (pred c d)) +; pred returns t/nil, as does pairwise +; reduce? + +(define (pairwise pred lst) + (cond ((null? lst) 't) + ((null? (cdr lst)) 't) + ((not (eqv? (pred (car lst) (cadr lst)) 'nil)) + (pairwise pred (cdr lst))) + (#t 'nil))) + +; not quite right, because behavior of underlying eqv unspecified +; in many cases according to r5rs +; do we really want is to ret t for distinct strings? + +; for (is x y) + +(define (ar-is2 a b) + (tnil (or (eqv? a b) + (and (string? a) (string? b) (string=? a b)) + (and (ar-false? a) (ar-false? b))))) + +; for all other uses of is + +(xdef is (lambda args (pairwise ar-is2 args))) + +(xdef err err) +(xdef nil 'nil) +(xdef t 't) + +(define (all test seq) + (or (null? seq) + (and (test (car seq)) (all test (cdr seq))))) + +(define (arc-list? x) (or (pair? x) (eqv? x 'nil) (eqv? x '()))) + +; Generic +: strings, lists, numbers. +; Return val has same type as first argument. + +(xdef + (lambda args + (cond ((null? args) 0) + ((char-or-string? (car args)) + (apply string-append + (map (lambda (a) (ar-coerce a 'string)) + args))) + ((arc-list? (car args)) + (ac-niltree (apply append (map ar-nil-terminate args)))) + (#t (apply + args))))) + +(define (char-or-string? x) (or (string? x) (char? x))) + +(define (ar-+2 x y) + (cond ((char-or-string? x) + (string-append (ar-coerce x 'string) (ar-coerce y 'string))) + ((and (arc-list? x) (arc-list? y)) + (ac-niltree (append (ar-nil-terminate x) (ar-nil-terminate y)))) + (#t (+ x y)))) + +(xdef - -) +(xdef * *) +(xdef / /) +(xdef mod modulo) +(xdef expt expt) +(xdef sqrt sqrt) + +; generic comparison + +(define (ar->2 x y) + (tnil (cond ((and (number? x) (number? y)) (> x y)) + ((and (string? x) (string? y)) (string>? x y)) + ((and (symbol? x) (symbol? y)) (string>? (symbol->string x) + (symbol->string y))) + ((and (char? x) (char? y)) (char>? x y)) + (#t (> x y))))) + +(xdef > (lambda args (pairwise ar->2 args))) + +(define (ar-<2 x y) + (tnil (cond ((and (number? x) (number? y)) (< x y)) + ((and (string? x) (string? y)) (string<? x y)) + ((and (symbol? x) (symbol? y)) (string<? (symbol->string x) + (symbol->string y))) + ((and (char? x) (char? y)) (char<? x y)) + (#t (< x y))))) + +(xdef < (lambda args (pairwise ar-<2 args))) + +(xdef len (lambda (x) + (cond ((string? x) (string-length x)) + ((hash-table? x) (hash-table-count x)) + (#t (length (ar-nil-terminate x)))))) + +(define (ar-tagged? x) + (and (vector? x) (eq? (vector-ref x 0) 'tagged))) + +(define (ar-tag type rep) + (cond ((eqv? (ar-type rep) type) rep) + (#t (vector 'tagged type rep)))) + +(xdef annotate ar-tag) + +; (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) + ((symbol? x) 'sym) + ((null? x) 'sym) + ((procedure? x) 'fn) + ((char? x) 'char) + ((string? x) 'string) + ((exint? x) 'int) + ((number? x) 'num) ; unsure about this + ((hash-table? x) 'table) + ((output-port? x) 'output) + ((input-port? x) 'input) + ((tcp-listener? x) 'socket) + ((exn? x) 'exception) + ((thread? x) 'thread) + (#t (err "Type: unknown type" x)))) +(xdef type ar-type) + +(define (ar-rep x) + (if (ar-tagged? x) + (vector-ref x 2) + x)) + +(xdef rep ar-rep) + +; currently rather a joke: returns interned symbols + +(define ar-gensym-count 0) + +(define (ar-gensym) + (set! ar-gensym-count (+ ar-gensym-count 1)) + (string->symbol (string-append "gs" (number->string ar-gensym-count)))) + +(xdef uniq ar-gensym) + +(xdef ccc call-with-current-continuation) + +(xdef infile open-input-file) + +(xdef outfile (lambda (f . args) + (open-output-file f + 'text + (if (equal? args '(append)) + 'append + 'truncate)))) + +(xdef instring open-input-string) +(xdef outstring open-output-string) + +; use as general fn for looking inside things + +(xdef inside get-output-string) + +(xdef stdout current-output-port) ; should be a vars +(xdef stdin current-input-port) +(xdef stderr current-error-port) + +(xdef call-w/stdout + (lambda (port thunk) + (parameterize ((current-output-port port)) (thunk)))) + +(xdef call-w/stdin + (lambda (port thunk) + (parameterize ((current-input-port port)) (thunk)))) + +(xdef readc (lambda str + (let ((c (read-char (if (pair? str) + (car str) + (current-input-port))))) + (if (eof-object? c) 'nil c)))) + + +(xdef readb (lambda str + (let ((c (read-byte (if (pair? str) + (car str) + (current-input-port))))) + (if (eof-object? c) 'nil c)))) + +(xdef peekc (lambda str + (let ((c (peek-char (if (pair? str) + (car str) + (current-input-port))))) + (if (eof-object? c) 'nil c)))) + +(xdef writec (lambda (c . args) + (write-char c + (if (pair? args) + (car args) + (current-output-port))) + c)) + +(xdef writeb (lambda (b . args) + (write-byte b + (if (pair? args) + (car args) + (current-output-port))) + b)) + +(define explicit-flush #f) + +(define (printwith f args) + (let ((port (if (> (length args) 1) + (cadr args) + (current-output-port)))) + (when (pair? args) + (f (ac-denil (car args)) port)) + (unless explicit-flush (flush-output port))) + 'nil) + +(xdef write (lambda args (printwith write args))) +(xdef disp (lambda args (printwith display args))) + +; sread = scheme read. eventually replace by writing read + +(xdef sread (lambda (p eof) + (let ((expr (read p))) + (if (eof-object? expr) eof expr)))) + +; these work in PLT but not scheme48 + +(define char->ascii char->integer) +(define ascii->char integer->char) + +(define (iround x) (inexact->exact (round x))) + +(define (ar-coerce x type . args) + (cond + ((ar-tagged? x) (err "Can't coerce annotated object")) + ((eqv? type (ar-type x)) x) + ((char? x) (case type + ((int) (char->ascii x)) + ((string) (string x)) + ((sym) (string->symbol (string x))) + (else (err "Can't coerce" x type)))) + ((exint? x) (case type + ((num) x) + ((char) (ascii->char x)) + ((string) (apply number->string x args)) + (else (err "Can't coerce" x type)))) + ((number? x) (case type + ((int) (iround x)) + ((char) (ascii->char (iround x))) + ((string) (apply number->string x args)) + (else (err "Can't coerce" x type)))) + ((string? x) (case type + ((sym) (string->symbol x)) + ((cons) (ac-niltree (string->list x))) + ((num) (or (apply string->number x args) + (err "Can't coerce" x type))) + ((int) (let ((n (apply string->number x args))) + (if n + (iround n) + (err "Can't coerce" x type)))) + (else (err "Can't coerce" x type)))) + ((pair? x) (case type + ((string) (apply string-append + (map (lambda (y) (ar-coerce y 'string)) + (ar-nil-terminate x)))) + (else (err "Can't coerce" x type)))) + ((eqv? x 'nil) (case type + ((string) "") + (else (err "Can't coerce" x type)))) + ((null? x) (case type + ((string) "") + (else (err "Can't coerce" x type)))) + ((symbol? x) (case type + ((string) (symbol->string x)) + (else (err "Can't coerce" x type)))) + (#t x))) + +(xdef coerce ar-coerce) + +(xdef open-socket (lambda (num) (tcp-listen num 50 #t))) + +; the 2050 means http requests currently capped at 2 meg +; http://list.cs.brown.edu/pipermail/plt-scheme/2005-August/009414.html + +(xdef socket-accept (lambda (s) + (let ((oc (current-custodian)) + (nc (make-custodian))) + (current-custodian nc) + (call-with-values + (lambda () (tcp-accept s)) + (lambda (in out) + (let ((in1 (make-limited-input-port in 100000 #t))) + (current-custodian oc) + (associate-custodian nc in1 out) + (list in1 + out + (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) +(xdef current-thread current-thread) + +(define (wrapnil f) (lambda args (apply f args) 'nil)) + +(xdef sleep (wrapnil sleep)) + +; Will system "execute" a half-finished string if thread killed +; in the middle of generating it? + +(xdef system (wrapnil system)) + +(xdef pipe-from (lambda (cmd) + (let ((tf (ar-tmpname))) + (system (string-append cmd " > " tf)) + (let ((str (open-input-file tf))) + (system (string-append "rm -f " tf)) + str)))) + +(define (ar-tmpname) + (call-with-input-file "/dev/urandom" + (lambda (rstr) + (do ((s "/tmp/") + (c (read-char rstr) (read-char rstr)) + (i 0 (+ i 1))) + ((>= i 16) s) + (set! s (string-append s + (string + (integer->char + (+ (char->integer #\a) + (modulo + (char->integer (read-char rstr)) + 26)))))))))) + +; PLT scheme provides only eq? and equal? hash tables, +; we need the latter for strings. + +(xdef table (lambda args + (let ((h (make-hash-table 'equal))) + (if (pair? args) ((car args) h)) + h))) + +;(xdef table (lambda args +; (fill-table (make-hash-table 'equal) +; (if (pair? args) (ac-denil (car args)) '())))) + +(define (fill-table h pairs) + (if (eq? pairs '()) + h + (let ((pair (car pairs))) + (begin (hash-table-put! h (car pair) (cadr pair)) + (fill-table h (cdr pairs)))))) + +(xdef maptable (lambda (fn table) ; arg is (fn (key value) ...) + (hash-table-for-each table fn) + table)) + +(define (protect during after) + (dynamic-wind (lambda () #t) during after)) + +(xdef protect protect) + +; need to use a better seed + +(xdef rand random) + +(xdef dir (lambda (name) + (ac-niltree (map path->string (directory-list name))))) + +; Would def mkdir in terms of make-directory and call that instead +; of system in ensure-dir, but make-directory is too weak: it doesn't +; create intermediate directories like mkdir -p. + +(xdef file-exists (lambda (name) + (if (file-exists? name) name 'nil))) + +(xdef dir-exists (lambda (name) + (if (directory-exists? name) name 'nil))) + +(xdef rmfile (wrapnil delete-file)) + +(xdef mvfile (lambda (old new) + (rename-file-or-directory old new #t) + 'nil)) + +; top level read-eval-print +; tle kept as a way to get a break loop when a scheme err + +(define (arc-eval expr) + (eval (ac expr '()))) + +(define (tle) + (display "Arc> ") + (let ((expr (read))) + (when (not (eqv? expr ':a)) + (write (arc-eval expr)) + (newline) + (tle)))) + +(define last-condition* #f) + +(define (tl) + (display "Use (quit) to quit, (tl) to return here after an interrupt.\n") + (tl2)) + +(define (tl2) + (display "arc> ") + (on-err (lambda (c) + (set! last-condition* c) + (display "Error: ") + (write (exn-message c)) + (newline) + (tl2)) + (lambda () + (let ((expr (read))) + (if (eqv? expr ':a) + 'done + (let ((val (arc-eval expr))) + (write (ac-denil val)) + (namespace-set-variable-value! '_that val) + (namespace-set-variable-value! '_thatexpr expr) + (newline) + (tl2))))))) + +(define (aload1 p) + (let ((x (read p))) + (if (eof-object? x) + #t + (begin + (arc-eval x) + (aload1 p))))) + +(define (atests1 p) + (let ((x (read p))) + (if (eof-object? x) + #t + (begin + (write x) + (newline) + (let ((v (arc-eval x))) + (if (ar-false? v) + (begin + (display " FAILED") + (newline)))) + (atests1 p))))) + +(define (aload filename) + (call-with-input-file filename aload1)) + +(define (test filename) + (call-with-input-file filename atests1)) + +(define (acompile1 ip op) + (let ((x (read ip))) + (if (eof-object? x) + #t + (let ((scm (ac x '()))) + (eval scm) + (pretty-print scm op) + (newline op) + (newline op) + (acompile1 ip op))))) + +; compile xx.arc to xx.arc.scm +; useful to examine the Arc compiler output +(define (acompile inname) + (let ((outname (string-append inname ".scm"))) + (if (file-exists? outname) + (delete-file outname)) + (call-with-input-file inname + (lambda (ip) + (call-with-output-file outname + (lambda (op) + (acompile1 ip op))))))) + +(xdef macex (lambda (e) (ac-macex (ac-denil e)))) + +(xdef macex1 (lambda (e) (ac-macex (ac-denil e) 'once))) + +(xdef eval (lambda (e) + (eval (ac (ac-denil e) '())))) + +; If an err occurs in an on-err expr, no val is returned and code +; after it doesn't get executed. Not quite what I had in mind. + +(define (on-err errfn f) + ((call-with-current-continuation + (lambda (k) + (lambda () + (with-handlers ((exn:fail? (lambda (c) + (k (lambda () (errfn c)))))) + (f))))))) +(xdef on-err on-err) + +(define (disp-to-string x) + (let ((o (open-output-string))) + (display x o) + (close-output-port o) + (get-output-string o))) + +(xdef details (lambda (c) + (disp-to-string (exn-message c)))) + +(xdef scar (lambda (x val) + (if (string? x) + (string-set! x 0 val) + (x-set-car! x val)) + val)) + +(xdef scdr (lambda (x val) + (if (string? x) + (err "Can't set cdr of a string" x) + (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. + +(define (string-replace! str val index) + (if (eqv? (string-length val) (- (string-length str) index)) + (do ((i index (+ i 1))) + ((= i (string-length str)) str) + (string-set! str i (string-ref val (- i index)))) + (err "Length mismatch between strings" str val index))) + +; Later may want to have multiple indices. + +(xdef sref + (lambda (com val ind) + (cond ((hash-table? com) (if (eqv? val 'nil) + (hash-table-remove! com ind) + (hash-table-put! com ind val))) + ((string? com) (string-set! com ind val)) + ((pair? com) (nth-set! com ind val)) + (#t (err "Can't set reference " com ind val))) + val)) + +(define (nth-set! 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 + +(define (bound? arcname) + (namespace-variable-value (ac-global-name arcname) + #t + (lambda () #f))) + +(xdef bound (lambda (x) (tnil (bound? x)))) + +(xdef newstring make-string) + +(xdef trunc (lambda (x) (inexact->exact (truncate x)))) + +; bad name + +(xdef exact (lambda (x) (tnil (exint? x)))) + +(xdef msec current-milliseconds) +(xdef current-process-milliseconds current-process-milliseconds) +(xdef current-gc-milliseconds current-gc-milliseconds) + +(xdef seconds current-seconds) + +(print-hash-table #t) + +(xdef client-ip (lambda (port) + (let-values (((x y) (tcp-addresses port))) + y))) + +; make sure only one thread at a time executes anything +; inside an atomic-invoke. atomic-invoke is allowed to +; nest within a thread; the thread-cell keeps track of +; whether this thread already holds the lock. + +(define ar-the-sema (make-semaphore 1)) + +(define ar-sema-cell (make-thread-cell #f)) + +(xdef atomic-invoke (lambda (f) + (if (thread-cell-ref ar-sema-cell) + (ar-apply f '()) + (begin + (thread-cell-set! ar-sema-cell #t) + (protect + (lambda () + (call-with-semaphore + ar-the-sema + (lambda () (ar-apply f '())))) + (lambda () + (thread-cell-set! ar-sema-cell #f))))))) + +(xdef dead (lambda (x) (tnil (thread-dead? x)))) + +; Added because Mzscheme buffers output. Not a permanent part of Arc. +; Only need to use when declare explicit-flush optimization. + +(xdef flushout (lambda () (flush-output) 't)) + +(xdef ssyntax (lambda (x) (tnil (ssyntax? x)))) + +(xdef ssexpand (lambda (x) + (if (symbol? x) (expand-ssyntax x) x))) + +(xdef quit exit) + +; there are two ways to close a TCP output port. +; (close o) waits for output to drain, then closes UNIX descriptor. +; (force-close o) discards buffered output, then closes UNIX desc. +; web servers need the latter to get rid of connections to +; clients that are not reading data. +; mzscheme close-output-port doesn't work (just raises an error) +; if there is buffered output for a non-responsive socket. +; must use custodian-shutdown-all instead. + +(define custodians (make-hash-table 'equal)) + +(define (associate-custodian c i o) + (hash-table-put! custodians i c) + (hash-table-put! custodians o c)) + +; if a port has a custodian, use it to close the port forcefully. +; also get rid of the reference to the custodian. +; sadly doing this to the input port also kills the output port. + +(define (try-custodian p) + (let ((c (hash-table-get custodians p #f))) + (if c + (begin + (custodian-shutdown-all c) + (hash-table-remove! custodians p) + #t) + #f))) + +(define (ar-close . args) + (map (lambda (p) + (cond ((input-port? p) (close-input-port p)) + ((output-port? p) (close-output-port p)) + ((tcp-listener? p) (tcp-close p)) + (#t (err "Can't close " p)))) + args) + (map (lambda (p) (try-custodian p)) args) ; free any custodian + 'nil) + +(xdef close ar-close) + +(xdef force-close (lambda args + (map (lambda (p) + (if (not (try-custodian p)) + (ar-close p))) + args) + 'nil)) + +(xdef memory current-memory-use) + +(xdef declare (lambda (key val) + (let ((flag (not (ar-false? val)))) + (case key + ((atstrings) (set! atstrings flag)) + ((direct-calls) (set! direct-calls flag)) + ((explicit-flush) (set! explicit-flush flag))) + val))) + +(putenv "TZ" ":GMT") + +(define (gmt-date sec) (seconds->date sec)) + +(xdef timedate + (lambda args + (let ((d (gmt-date (if (pair? args) (car args) (current-seconds))))) + (ac-niltree (list (date-second d) + (date-minute d) + (date-hour d) + (date-day d) + (date-month d) + (date-year d)))))) + +(xdef sin sin) +(xdef cos cos) +(xdef tan tan) +(xdef asin asin) +(xdef acos acos) +(xdef atan atan) +(xdef log log) + +(define (codestring s) + (let ((i (atpos s 0))) + (if i + (cons (substring s 0 i) + (let* ((rest (substring s (+ i 1))) + (in (open-input-string rest)) + (expr (read in)) + (i2 (let-values (((x y z) (port-next-location in))) z))) + (close-input-port in) + (cons expr (codestring (substring rest (- i2 1)))))) + (list s)))) + +; First unescaped @ in s, if any. Escape by doubling. + +(define (atpos s i) + (cond ((eqv? i (string-length s)) + #f) + ((eqv? (string-ref s i) #\@) + (if (and (< (+ i 1) (string-length s)) + (not (eqv? (string-ref s (+ i 1)) #\@))) + i + (atpos s (+ i 2)))) + (#t + (atpos s (+ i 1))))) + +(define (unescape-ats s) + (list->string (letrec ((unesc (lambda (cs) + (cond + ((null? cs) + '()) + ((and (eqv? (car cs) #\@) + (not (null? (cdr cs))) + (eqv? (cadr cs) #\@)) + (unesc (cdr cs))) + (#t + (cons (car cs) (unesc (cdr cs)))))))) + (unesc (string->list s))))) + +) + @@ -0,0 +1,671 @@ +; Application Server. Layer inserted 2 Sep 06. + +; ideas: +; def a general notion of apps of which prompt is one, news another +; give each user a place to store data? A home dir? + +; A user is simply a string: "pg". Use /whoami to test user cookie. + +(= hpwfile* "arc/hpw" + oidfile* "arc/openids" + adminfile* "arc/admins" + cookfile* "arc/cooks") + +(def asv ((o port 8080)) + (load-userinfo) + (serve port)) + +(def load-userinfo () + (= hpasswords* (safe-load-table hpwfile*) + openids* (safe-load-table oidfile*) + admins* (map string (errsafe (readfile adminfile*))) + cookie->user* (safe-load-table cookfile*)) + (maptable (fn (k v) (= (user->cookie* v) k)) + cookie->user*)) + +; idea: a bidirectional table, so don't need two vars (and sets) + +(= cookie->user* (table) user->cookie* (table) logins* (table)) + +(def get-user (req) + (let u (aand (alref req!cooks "user") (cookie->user* (sym it))) + (when u (= (logins* u) req!ip)) + u)) + +(mac when-umatch (user req . body) + `(if (is ,user (get-user ,req)) + (do ,@body) + (mismatch-message))) + +(def mismatch-message () + (prn "Dead link: users don't match.")) + +(mac when-umatch/r (user req . body) + `(if (is ,user (get-user ,req)) + (do ,@body) + "mismatch")) + +(defop mismatch req (mismatch-message)) + +(mac uform (user req after . body) + `(aform (fn (,req) + (when-umatch ,user ,req + ,after)) + ,@body)) + +(mac urform (user req after . body) + `(arform (fn (,req) + (when-umatch/r ,user ,req + ,after)) + ,@body)) + +; Like onlink, but checks that user submitting the request is the +; same it was generated for. For extra protection could log the +; username and ip addr of every genlink, and check if they match. + +(mac ulink (user text . body) + (w/uniq req + `(linkf ,text (,req) + (when-umatch ,user ,req ,@body)))) + + +(defop admin req (admin-gate (get-user req))) + +(def admin-gate (u) + (if (admin u) + (admin-page u) + (login-page 'login nil + (fn (u ip) (admin-gate u))))) + +(def admin (u) (and u (mem u admins*))) + +(def user-exists (u) (and u (hpasswords* u) u)) + +(def admin-page (user . msg) + (whitepage + (prbold "Admin: ") + (hspace 20) + (pr user " | ") + (w/link (do (logout-user user) + (whitepage (pr "Bye " user "."))) + (pr "logout")) + (when msg (hspace 10) (map pr msg)) + (br2) + (aform (fn (req) + (when-umatch user req + (with (u (arg req "u") p (arg req "p")) + (if (or (no u) (no p) (is u "") (is p "")) + (pr "Bad data.") + (user-exists u) + (admin-page user "User already exists: " u) + (do (create-acct u p) + (admin-page user)))))) + (pwfields "create (server) account")))) + +(def cook-user (user) + (let id (new-user-cookie) + (= (cookie->user* id) user + (user->cookie* user) id) + (save-table cookie->user* cookfile*) + id)) + +; Unique-ids are only unique per server invocation. + +(def new-user-cookie () + (let id (unique-id) + (if (cookie->user* id) (new-user-cookie) id))) + +(def logout-user (user) + (wipe (logins* user)) + (wipe (cookie->user* (user->cookie* user)) (user->cookie* user)) + (save-table cookie->user* cookfile*)) + +(def create-acct (user pw) + (set (dc-usernames* (downcase user))) + (set-pw user pw)) + +(def disable-acct (user) + (set-pw user (rand-string 20)) + (logout-user user)) + +(def set-pw (user pw) + (= (hpasswords* user) (and pw (shash pw))) + (save-table hpasswords* hpwfile*)) + +(def hello-page (user ip) + (whitepage (prs "hello" user "at" ip))) + +(defop login req (login-page 'login)) + +; switch is one of: register, login, both + +; afterward is either a function on the newly created username and +; ip address, in which case it is called to generate the next page +; after a successful login, or a pair of (function url), which means +; call the function, then redirect to the url. + +; classic example of something that should just "return" a val +; via a continuation rather than going to a new page. + +(def login-page (switch (o msg nil) (o afterward hello-page)) + (whitepage + (pagemessage msg) + (when (in switch 'login 'both) + (login-form "Login" switch login-handler afterward) + (hook 'login-form afterward) + (br2)) + (when (in switch 'register 'both) + (login-form "Create Account" switch create-handler afterward)))) + +(def login-form (label switch handler afterward) + (prbold label) + (br2) + (fnform (fn (req) (handler req switch afterward)) + (fn () (pwfields (downcase label))) + (acons afterward))) + +(def login-handler (req switch afterward) + (logout-user (get-user req)) + (aif (good-login (arg req "u") (arg req "p") req!ip) + (login it req!ip (user->cookie* it) afterward) + (failed-login switch "Bad login." afterward))) + +(def create-handler (req switch afterward) + (logout-user (get-user req)) + (with (user (arg req "u") pw (arg req "p")) + (aif (bad-newacct user pw) + (failed-login switch it afterward) + (do (create-acct user pw) + (login user req!ip (cook-user user) afterward))))) + +(def login (user ip cookie afterward) + (= (logins* user) ip) + (prcookie cookie) + (if (acons afterward) + (let (f url) afterward + (f user ip) + url) + (do (prn) + (afterward user ip)))) + +(def failed-login (switch msg afterward) + (if (acons afterward) + (flink (fn ignore (login-page switch msg afterward))) + (do (prn) + (login-page switch msg afterward)))) + +(def prcookie (cook) + (prn "Set-Cookie: user=" cook "; expires=Sun, 17-Jan-2038 19:14:07 GMT")) + +(def pwfields ((o label "login")) + (inputs u username 20 nil + p password 20 nil) + (br) + (submit label)) + +(= good-logins* (queue) bad-logins* (queue)) + +(def good-login (user pw ip) + (let record (list (seconds) ip user) + (if (and user pw (aand (shash pw) (is it (hpasswords* user)))) + (do (unless (user->cookie* user) (cook-user user)) + (enq-limit record good-logins*) + user) + (do (enq-limit record bad-logins*) + nil)))) + +; Create a file in case people have quote chars in their pws. I can't +; believe there's no way to just send the chars. + +(def shash (str) + (let fname (+ "/tmp/shash" (rand-string 10)) + (w/outfile f fname (disp str f)) + (let res (tostring (system (+ "openssl dgst -sha1 <" fname))) + (do1 (cut res 0 (- (len res) 1)) + (rmfile fname))))) + +(= dc-usernames* (table)) + +(def username-taken (user) + (when (empty dc-usernames*) + (each (k v) hpasswords* + (set (dc-usernames* (downcase k))))) + (dc-usernames* (downcase user))) + +(def bad-newacct (user pw) + (if (no (goodname user 2 15)) + "Usernames can only contain letters, digits, dashes and + underscores, and should be between 2 and 15 characters long. + Please choose another." + (username-taken user) + "That username is taken. Please choose another." + (or (no pw) (< (len pw) 4)) + "Passwords should be a least 4 characters long. Please + choose another." + nil)) + +(def goodname (str (o min 1) (o max nil)) + (and (isa str 'string) + (>= (len str) min) + (~find (fn (c) (no (or (alphadig c) (in c #\- #\_)))) + str) + (isnt (str 0) #\-) + (or (no max) (<= (len str) max)) + str)) + +(defop logout req + (aif (get-user req) + (do (logout-user it) + (pr "Logged out.")) + (pr "You were not logged in."))) + +(defop whoami req + (aif (get-user req) + (prs it 'at req!ip) + (do (pr "You are not logged in. ") + (w/link (login-page 'both) (pr "Log in")) + (pr ".")))) + + +(= formwid* 60 bigformwid* 80 numwid* 16 formatdoc-url* nil) + +; Eventually figure out a way to separate type name from format of +; input field, instead of having e.g. toks and bigtoks + +(def varfield (typ id val) + (if (in typ 'string 'string1 'url) + (gentag input type 'text name id value val size formwid*) + (in typ 'num 'int 'posint 'sym) + (gentag input type 'text name id value val size numwid*) + (in typ 'users 'toks) + (gentag input type 'text name id value (tostring (apply prs val)) + size formwid*) + (is typ 'sexpr) + (gentag input type 'text name id + value (tostring (map [do (write _) (sp)] val)) + size formwid*) + (in typ 'syms 'text 'doc 'mdtext 'mdtext2 'lines 'bigtoks) + (let text (if (in typ 'syms 'bigtoks) + (tostring (apply prs val)) + (is typ 'lines) + (tostring (apply pr (intersperse #\newline val))) + (in typ 'mdtext 'mdtext2) + (unmarkdown val) + (no val) + "" + val) + (tag (textarea cols (if (is typ 'doc) bigformwid* formwid*) + rows (needrows text formwid* 4) + wrap 'virtual + style (if (is typ 'doc) "font-size:8.5pt") + name id) + (prn) ; needed or 1 initial newline gets chopped off + (pr text)) + (when (and formatdoc-url* (in typ 'mdtext 'mdtext2)) + (pr " ") + (tag (font size -2) + (link "help" formatdoc-url* (gray 175))))) + (caris typ 'choice) + (menu id (cddr typ) val) + (is typ 'yesno) + (menu id '("yes" "no") (if val "yes" "no")) + (is typ 'hexcol) + (gentag input type 'text name id value val) + (is typ 'time) + (gentag input type 'text name id value (if val (english-time val) "")) + (is typ 'date) + (gentag input type 'text name id value (if val (english-date val) "")) + (err "unknown varfield type" typ))) + +(def text-rows (text wid (o pad 3)) + (+ (trunc (/ (len text) (* wid .8))) pad)) + +(def needrows (text cols (o pad 0)) + (+ pad (max (+ 1 (count #\newline text)) + (roundup (/ (len text) (- cols 5)))))) + +(def varline (typ id val (o liveurls)) + (if (in typ 'users 'syms 'toks 'bigtoks) (apply prs val) + (is typ 'lines) (map prn val) + (is typ 'yesno) (pr (if val 'yes 'no)) + (caris typ 'choice) (varline (cadr typ) nil val) + (is typ 'url) (if (and liveurls (valid-url val)) + (link val val) + (pr val)) + (text-type typ) (pr (or val "")) + (pr val))) + +(def text-type (typ) (in typ 'string 'string1 'url 'text 'mdtext 'mdtext2)) + +; Newlines in forms come back as /r/n. Only want the /ns. Currently +; remove the /rs in individual cases below. Could do it in aform or +; even in the parsing of http requests, in the server. + +; Need the calls to striptags so that news users can't get html +; into a title or comment by editing it. If want a form that +; can take html, just create another typ for it. + +(def readvar (typ str (o fail nil)) + (case (carif typ) + string (striptags str) + string1 (if (blank str) fail (striptags str)) + url (if (blank str) "" (valid-url str) (clean-url str) fail) + num (let n (saferead str) (if (number n) n fail)) + int (let n (saferead str) + (if (number n) (round n) fail)) + posint (let n (saferead str) + (if (and (number n) (> n 0)) (round n) fail)) + text (striptags str) + doc (striptags str) + mdtext (md-from-form str) + mdtext2 (md-from-form str t) ; for md with no links + sym (or (sym:car:tokens str) fail) + syms (map sym (tokens str)) + sexpr (errsafe (readall str)) + users (rem [no (goodname _)] (tokens str)) + toks (tokens str) + bigtoks (tokens str) + lines (lines str) + choice (readvar (cadr typ) str) + yesno (is str "yes") + hexcol (if (hex>color str) str fail) + time (or (errsafe (parse-time str)) fail) + date (or (errsafe (parse-date str)) fail) + (err "unknown readvar type" typ))) + +; 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)) + (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 + (br) + (submit button)))) + +(def showvars (fields (o liveurls)) + (each (typ id val view mod question) fields + (when view + (when question + (tr (td (prn question)))) + (tr (unless question (tag (td valign 'top) (pr id ":"))) + (td (if mod + (varfield typ id val) + (varline typ id val liveurls)))) + (prn)))) + +; http://daringfireball.net/projects/markdown/syntax + +(def md-from-form (str (o nolinks)) + (markdown (trim (rem #\return (esc-tags str)) 'end) 60 nolinks)) + +(def markdown (s (o maxurl) (o nolinks)) + (let ital nil + (tostring + (forlen i s + (iflet (newi spaces) (indented-code s i (if (is i 0) 2 0)) + (do (pr "<p><pre><code>") + (let cb (code-block s (- newi spaces 1)) + (pr cb) + (= i (+ (- newi spaces 1) (len cb)))) + (pr "</code></pre>")) + (iflet newi (parabreak s i (if (is i 0) 1 0)) + (do (unless (is i 0) (pr "<p>")) + (= i (- newi 1))) + (and (is (s i) #\*) + (or ital + (atend i s) + (and (~whitec (s (+ i 1))) + (pos #\* s (+ i 1))))) + (do (pr (if ital "</i>" "<i>")) + (= ital (no ital))) + (and (no nolinks) + (or (litmatch "http://" s i) + (litmatch "https://" s i))) + (withs (n (urlend s i) + url (clean-url (cut s i n))) + (tag (a href url rel 'nofollow) + (pr (if (no maxurl) url (ellipsize url maxurl)))) + (= i (- n 1))) + (writec (s i)))))))) + +(def indented-code (s i (o newlines 0) (o spaces 0)) + (let c (s i) + (if (nonwhite c) + (if (and (> newlines 1) (> spaces 1)) + (list i spaces) + nil) + (atend i s) + nil + (is c #\newline) + (indented-code s (+ i 1) (+ newlines 1) 0) + (indented-code s (+ i 1) newlines (+ spaces 1))))) + +; If i is start a paragraph break, returns index of start of next para. + +(def parabreak (s i (o newlines 0)) + (let c (s i) + (if (or (nonwhite c) (atend i s)) + (if (> newlines 1) i nil) + (parabreak s (+ i 1) (+ newlines (if (is c #\newline) 1 0)))))) + +; Returns the indices of the next paragraph break in s, if any. + +(def next-parabreak (s i) + (unless (atend i s) + (aif (parabreak s i) + (list i it) + (next-parabreak s (+ i 1))))) + +(def paras (s (o i 0)) + (if (atend i s) + nil + (iflet (endthis startnext) (next-parabreak s i) + (cons (cut s i endthis) + (paras s startnext)) + (list (trim (cut s i) 'end))))) + + +; Returns the index of the first char not part of the url beginning +; at i, or len of string if url goes all the way to the end. + +; 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-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 +; balancing a previous open delimiter. + +(def urlend (s i (o indelim)) + (let c (s i) + (if (atend i s) + (if ((orf punc whitec opendelim) c) + i + (closedelim c) + (if indelim (+ i 1) i) + (+ i 1)) + (if (or (whitec c) + (and (punc c) (whitec (s (+ i 1)))) + (and ((orf whitec punc) (s (+ i 1))) + (or (opendelim c) + (and (closedelim c) (no indelim))))) + i + (urlend s (+ i 1) (or (opendelim c) + (and indelim (no (closedelim c))))))))) + +(def opendelim (c) (in c #\< #\( #\[ #\{)) + +(def closedelim (c) (in c #\> #\) #\] #\})) + + +(def code-block (s i) + (tostring + (until (let left (- (len s) i 1) + (or (is left 0) + (and (> left 2) + (is (s (+ i 1)) #\newline) + (nonwhite (s (+ i 2)))))) + (writec (s (++ i)))))) + +(def unmarkdown (s) + (tostring + (forlen i s + (if (litmatch "<p>" s i) + (do (++ i 2) + (unless (is i 2) (pr "\n\n"))) + (litmatch "<i>" s i) + (do (++ i 2) (pr #\*)) + (litmatch "</i>" s i) + (do (++ i 3) (pr #\*)) + (litmatch "<a href=" s i) + (let endurl (posmatch [in _ #\> #\space] s (+ i 9)) + (if endurl + (do (pr (cut s (+ i 9) (- endurl 1))) + (= i (aif (posmatch "</a>" s endurl) + (+ it 3) + endurl))) + (writec (s i)))) + (litmatch "<pre><code>" s i) + (awhen (findsubseq "</code></pre>" s (+ i 12)) + (pr (cut s (+ i 11) it)) + (= i (+ it 12))) + (writec (s i)))))) + + +(def english-time (min) + (let n (mod min 720) + (string (let h (trunc (/ n 60)) (if (is h 0) "12" h)) + ":" + (let m (mod n 60) + (if (is m 0) "00" + (< m 10) (string "0" m) + m)) + (if (is min 0) " midnight" + (is min 720) " noon" + (>= min 720) " pm" + " am")))) + +(def parse-time (s) + (let (nums (o label "")) (halve s letter) + (with ((h (o m 0)) (map int (tokens nums ~digit)) + cleanlabel (downcase (rem ~alphadig label))) + (+ (* (if (is h 12) + (if (in cleanlabel "am" "midnight") + 0 + 12) + (is cleanlabel "am") + h + (+ h 12)) + 60) + m)))) + + +(= months* '("January" "February" "March" "April" "May" "June" "July" + "August" "September" "October" "November" "December")) + +(def english-date ((y m d)) + (string d " " (months* (- m 1)) " " y)) + +(= month-names* (obj "january" 1 "jan" 1 + "february" 2 "feb" 2 + "march" 3 "mar" 3 + "april" 4 "apr" 4 + "may" 5 + "june" 6 "jun" 6 + "july" 7 "jul" 7 + "august" 8 "aug" 8 + "september" 9 "sept" 9 "sep" 9 + "october" 10 "oct" 10 + "november" 11 "nov" 11 + "december" 12 "dec" 12)) + +(def monthnum (s) (month-names* (downcase s))) + +; Doesn't work for BC dates. + +(def parse-date (s) + (let nums (date-nums s) + (if (valid-date nums) + nums + (err (string "Invalid date: " s))))) + +(def date-nums (s) + (with ((ynow mnow dnow) (date) + toks (tokens s ~alphadig)) + (if (all [all digit _] toks) + (let nums (map int toks) + (case (len nums) + 1 (list ynow mnow (car nums)) + 2 (iflet d (find [> _ 12] nums) + (list ynow (find [isnt _ d] nums) d) + (cons ynow nums)) + (if (> (car nums) 31) + (firstn 3 nums) + (rev (firstn 3 nums))))) + ([all digit _] (car toks)) + (withs ((ds ms ys) toks + d (int ds)) + (aif (monthnum ms) + (list (or (errsafe (int ys)) ynow) + it + d) + nil)) + (monthnum (car toks)) + (let (ms ds ys) toks + (aif (errsafe (int ds)) + (list (or (errsafe (int ys)) ynow) + (monthnum (car toks)) + it) + nil)) + nil))) + +; To be correct needs to know days per month, and about leap years + +(def valid-date ((y m d)) + (and y m d + (< 0 m 13) + (< 0 d 32))) + +(mac defopl (name parm . body) + `(defop ,name ,parm + (if (get-user ,parm) + (do ,@body) + (login-page 'both + "You need to be logged in to do that." + (list (fn (u ip)) + (string ',name (reassemble-args ,parm))))))) + @@ -0,0 +1,1700 @@ +; Main Arc lib. Ported to Scheme version Jul 06. + +; don't like names of conswhen and consif + +; need better way of generating strings; too many calls to string +; maybe strings with escape char for evaluation +; make foo~bar equiv of foo:~bar (in expand-ssyntax) +; add sigs of ops defined in ac.scm +; get hold of error types within arc +; does macex have to be defined in scheme instead of using def below? +; write disp, read, write in arc +; could I get all of macros up into arc.arc? +; warn when shadow a global name +; some simple regexp/parsing plan + +; compromises in this implementation: +; no objs in code +; (mac testlit args (listtab args)) breaks when called +; separate string type +; (= (cdr (cdr str)) "foo") couldn't work because no way to get str tail +; not sure this is a mistake; strings may be subtly different from +; lists of chars + + +(assign do (annotate 'mac + (fn args `((fn () ,@args))))) + +(assign safeset (annotate 'mac + (fn (var val) + `(do (if (bound ',var) + (do (disp "*** redefining " (stderr)) + (disp ',var (stderr)) + (disp #\newline (stderr)))) + (assign ,var ,val))))) + +(assign def (annotate 'mac + (fn (name parms . body) + `(do (sref sig ',parms ',name) + (safeset ,name (fn ,parms ,@body)))))) + +(def caar (xs) (car (car xs))) +(def cadr (xs) (car (cdr xs))) +(def cddr (xs) (cdr (cdr xs))) + +(def no (x) (is x nil)) + +(def acons (x) (is (type x) 'cons)) + +(def atom (x) (no (acons x))) + +; Can return to this def once Rtm gets ac to make all rest args +; nil-terminated lists. + +; (def list args args) + +(def copylist (xs) + (if (no xs) + nil + (cons (car xs) (copylist (cdr xs))))) + +(def list args (copylist args)) + +(def idfn (x) x) + +; Maybe later make this internal. Useful to let xs be a fn? + +(def map1 (f xs) + (if (no xs) + nil + (cons (f (car xs)) (map1 f (cdr xs))))) + +(def pair (xs (o f list)) + (if (no xs) + nil + (no (cdr xs)) + (list (list (car xs))) + (cons (f (car xs) (cadr xs)) + (pair (cddr xs) f)))) + +(assign mac (annotate 'mac + (fn (name parms . body) + `(do (sref sig ',parms ',name) + (safeset ,name (annotate 'mac (fn ,parms ,@body))))))) + +(mac and args + (if args + (if (cdr args) + `(if ,(car args) (and ,@(cdr args))) + (car args)) + 't)) + +(def assoc (key al) + (if (atom al) + nil + (and (acons (car al)) (is (caar al) key)) + (car al) + (assoc key (cdr al)))) + +(def alref (al key) (cadr (assoc key al))) + +(mac with (parms . body) + `((fn ,(map1 car (pair parms)) + ,@body) + ,@(map1 cadr (pair parms)))) + +(mac let (var val . body) + `(with (,var ,val) ,@body)) + +(mac withs (parms . body) + (if (no parms) + `(do ,@body) + `(let ,(car parms) ,(cadr parms) + (withs ,(cddr parms) ,@body)))) + +; Rtm prefers to overload + to do this + +(def join args + (if (no args) + nil + (let a (car args) + (if (no a) + (apply join (cdr args)) + (cons (car a) (apply join (cdr a) (cdr args))))))) + +; Need rfn for use in macro expansions. + +(mac rfn (name parms . body) + `(let ,name nil + (assign ,name (fn ,parms ,@body)))) + +(mac afn (parms . body) + `(let self nil + (assign self (fn ,parms ,@body)))) + +; Ac expands x:y:z into (compose x y z), ~x into (complement x) + +; Only used when the call to compose doesn't occur in functional position. +; Composes in functional position are transformed away by ac. + +(mac compose args + (let g (uniq) + `(fn ,g + ,((afn (fs) + (if (cdr fs) + (list (car fs) (self (cdr fs))) + `(apply ,(if (car fs) (car fs) 'idfn) ,g))) + args)))) + +; Ditto: complement in functional position optimized by ac. + +(mac complement (f) + (let g (uniq) + `(fn ,g (no (apply ,f ,g))))) + +(def rev (xs) + ((afn (xs acc) + (if (no xs) + acc + (self (cdr xs) (cons (car xs) acc)))) + xs nil)) + +(def isnt (x y) (no (is x y))) + +(mac w/uniq (names . body) + (if (acons names) + `(with ,(apply + nil (map1 (fn (n) (list n '(uniq))) + names)) + ,@body) + `(let ,names (uniq) ,@body))) + +(mac or args + (and args + (w/uniq g + `(let ,g ,(car args) + (if ,g ,g (or ,@(cdr args))))))) + +(def alist (x) (or (no x) (is (type x) 'cons))) + +(mac in (x . choices) + (w/uniq g + `(let ,g ,x + (or ,@(map1 (fn (c) `(is ,g ,c)) choices))))) + +; Could take n args, but have never once needed that. + +(def iso (x y) + (or (is x y) + (and (acons x) + (acons y) + (iso (car x) (car y)) + (iso (cdr x) (cdr y))))) + +(mac when (test . body) + `(if ,test (do ,@body))) + +(mac unless (test . body) + `(if (no ,test) (do ,@body))) + +(mac while (test . body) + (w/uniq (gf gp) + `((rfn ,gf (,gp) + (when ,gp ,@body (,gf ,test))) + ,test))) + +(def empty (seq) + (or (no seq) + (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))))) + +(def recstring (test s (o start 0)) + ((afn (i) + (and (< i (len s)) + (or (test i) + (self (+ i 1))))) + start)) + +(def testify (x) + (if (isa x 'fn) x [is _ x])) + +; Like keep, seems like some shouldn't testify. But find should, +; and all probably should. + +(def some (test seq) + (let f (testify test) + (if (alist seq) + (reclist f:car seq) + (recstring f:seq seq)))) + +(def all (test seq) + (~some (complement (testify test)) seq)) + +(def mem (test seq) + (let f (testify test) + (reclist [if (f:car _) _] seq))) + +(def find (test seq) + (let f (testify test) + (if (alist seq) + (reclist [if (f:car _) (car _)] seq) + (recstring [if (f:seq _) (seq _)] seq)))) + +(def isa (x y) (is (type x) y)) + +; Possible to write map without map1, but makes News 3x slower. + +;(def map (f . seqs) +; (if (some1 no seqs) +; nil +; (no (cdr seqs)) +; (let s1 (car seqs) +; (cons (f (car s1)) +; (map f (cdr s1)))) +; (cons (apply f (map car seqs)) +; (apply map f (map cdr seqs))))) + + +(def map (f . seqs) + (if (some [isa _ 'string] seqs) + (withs (n (apply min (map len seqs)) + new (newstring n)) + ((afn (i) + (if (is i n) + new + (do (sref new (apply f (map [_ i] seqs)) i) + (self (+ i 1))))) + 0)) + (no (cdr seqs)) + (map1 f (car seqs)) + ((afn (seqs) + (if (some no seqs) + nil + (cons (apply f (map1 car seqs)) + (self (map1 cdr seqs))))) + seqs))) + +(def mappend (f . args) + (apply + nil (apply map f args))) + +(def firstn (n xs) + (if (no n) xs + (and (> n 0) xs) (cons (car xs) (firstn (- n 1) (cdr xs))) + nil)) + +(def nthcdr (n xs) + (if (no n) xs + (> n 0) (nthcdr (- n 1) (cdr xs)) + xs)) + +; Generalization of pair: (tuples x) = (pair x) + +(def tuples (xs (o n 2)) + (if (no xs) + nil + (cons (firstn n xs) + (tuples (nthcdr n xs) n)))) + +; If ok to do with =, why not with def? But see if use it. + +(mac defs args + `(do ,@(map [cons 'def _] (tuples args 3)))) + +(def caris (x val) + (and (acons x) (is (car x) val))) + +(def warn (msg . args) + (disp (+ "Warning: " msg ". ")) + (map [do (write _) (disp " ")] args) + (disp #\newline)) + +(mac atomic body + `(atomic-invoke (fn () ,@body))) + +(mac atlet args + `(atomic (let ,@args))) + +(mac atwith args + `(atomic (with ,@args))) + +(mac atwiths args + `(atomic (withs ,@args))) + + +; setforms returns (vars get set) for a place based on car of an expr +; vars is a list of gensyms alternating with expressions whose vals they +; should be bound to, suitable for use as first arg to withs +; get is an expression returning the current value in the place +; set is an expression representing a function of one argument +; that stores a new value in the place + +; A bit gross that it works based on the *name* in the car, but maybe +; wrong to worry. Macros live in expression land. + +; seems meaningful to e.g. (push 1 (pop x)) if (car x) is a cons. +; can't in cl though. could I define a setter for push or pop? + +(assign setter (table)) + +(mac defset (name parms . body) + (w/uniq gexpr + `(sref setter + (fn (,gexpr) + (let ,parms (cdr ,gexpr) + ,@body)) + ',name))) + +(defset car (x) + (w/uniq g + (list (list g x) + `(car ,g) + `(fn (val) (scar ,g val))))) + +(defset cdr (x) + (w/uniq g + (list (list g x) + `(cdr ,g) + `(fn (val) (scdr ,g val))))) + +(defset caar (x) + (w/uniq g + (list (list g x) + `(caar ,g) + `(fn (val) (scar (car ,g) val))))) + +(defset cadr (x) + (w/uniq g + (list (list g x) + `(cadr ,g) + `(fn (val) (scar (cdr ,g) val))))) + +(defset cddr (x) + (w/uniq g + (list (list g x) + `(cddr ,g) + `(fn (val) (scdr (cdr ,g) val))))) + +; Note: if expr0 macroexpands into any expression whose car doesn't +; have a setter, setforms assumes it's a data structure in functional +; position. Such bugs will be seen only when the code is executed, when +; sref complains it can't set a reference to a function. + +(def setforms (expr0) + (let expr (macex expr0) + (if (isa expr 'sym) + (if (ssyntax expr) + (setforms (ssexpand expr)) + (w/uniq (g h) + (list (list g expr) + g + `(fn (,h) (assign ,expr ,h))))) + ; make it also work for uncompressed calls to compose + (and (acons expr) (metafn (car expr))) + (setforms (expand-metafn-call (ssexpand (car expr)) (cdr expr))) + (and (acons expr) (acons (car expr)) (is (caar expr) 'get)) + (setforms (list (cadr expr) (cadr (car expr)))) + (let f (setter (car expr)) + (if f + (f expr) + ; assumed to be data structure in fn position + (do (when (caris (car expr) 'fn) + (warn "Inverting what looks like a function call" + expr0 expr)) + (w/uniq (g h) + (let argsyms (map [uniq] (cdr expr)) + (list (+ (list g (car expr)) + (mappend list argsyms (cdr expr))) + `(,g ,@argsyms) + `(fn (,h) (sref ,g ,h ,(car argsyms)))))))))))) + +(def metafn (x) + (or (ssyntax x) + (and (acons x) (in (car x) 'compose 'complement)))) + +(def expand-metafn-call (f args) + (if (is (car f) 'compose) + ((afn (fs) + (if (caris (car fs) 'compose) ; nested compose + (self (join (cdr (car fs)) (cdr fs))) + (cdr fs) + (list (car fs) (self (cdr fs))) + (cons (car fs) args))) + (cdr f)) + (is (car f) 'no) + (err "Can't invert " (cons f args)) + (cons f args))) + +(def expand= (place val) + (if (and (isa place 'sym) (~ssyntax place)) + `(assign ,place ,val) + (let (vars prev setter) (setforms place) + (w/uniq g + `(atwith ,(+ vars (list g val)) + (,setter ,g)))))) + +(def expand=list (terms) + `(do ,@(map (fn ((p v)) (expand= p v)) ; [apply expand= _] + (pair terms)))) + +(mac = args + (expand=list args)) + +(mac loop (start test update . body) + (w/uniq (gfn gparm) + `(do ,start + ((rfn ,gfn (,gparm) + (if ,gparm + (do ,@body ,update (,gfn ,test)))) + ,test)))) + +(mac for (v init max . body) + (w/uniq (gi gm) + `(with (,v nil ,gi ,init ,gm (+ ,max 1)) + (loop (assign ,v ,gi) (< ,v ,gm) (assign ,v (+ ,v 1)) + ,@body)))) + +(mac down (v init min . body) + (w/uniq (gi gm) + `(with (,v nil ,gi ,init ,gm (- ,min 1)) + (loop (assign ,v ,gi) (> ,v ,gm) (assign ,v (- ,v 1)) + ,@body)))) + +(mac repeat (n . body) + `(for ,(uniq) 1 ,n ,@body)) + +; could bind index instead of gensym + +(mac each (var expr . body) + (w/uniq (gseq gf gv) + `(let ,gseq ,expr + (if (alist ,gseq) + ((rfn ,gf (,gv) + (when (acons ,gv) + (let ,var (car ,gv) ,@body) + (,gf (cdr ,gv)))) + ,gseq) + (isa ,gseq 'table) + (maptable (fn ,var ,@body) + ,gseq) + (for ,gv 0 (- (len ,gseq) 1) + (let ,var (,gseq ,gv) ,@body)))))) + +; (nthcdr x y) = (cut y x). + +(def cut (seq start (o end)) + (let end (if (no end) (len seq) + (< end 0) (+ (len seq) end) + end) + (if (isa seq 'string) + (let s2 (newstring (- end start)) + (for i 0 (- end start 1) + (= (s2 i) (seq (+ start i)))) + s2) + (firstn (- end start) (nthcdr start seq))))) + +(mac whilet (var test . body) + (w/uniq (gf gp) + `((rfn ,gf (,gp) + (let ,var ,gp + (when ,var ,@body (,gf ,test)))) + ,test))) + +(def last (xs) + (if (cdr xs) + (last (cdr xs)) + (car xs))) + +(def rem (test seq) + (let f (testify test) + (if (alist seq) + ((afn (s) + (if (no s) nil + (f (car s)) (self (cdr s)) + (cons (car s) (self (cdr s))))) + seq) + (coerce (rem test (coerce seq 'cons)) 'string)))) + +; Seems like keep doesn't need to testify-- would be better to +; be able to use tables as fns. But rem does need to, because +; often want to rem a table from a list. So maybe the right answer +; is to make keep the more primitive, not rem. + +(def keep (test seq) + (rem (complement (testify test)) seq)) + +;(def trues (f seq) +; (rem nil (map f seq))) + +(def trues (f xs) + (and xs + (let fx (f (car xs)) + (if fx + (cons fx (trues f (cdr xs))) + (trues f (cdr xs)))))) + +(mac do1 args + (w/uniq g + `(let ,g ,(car args) + ,@(cdr args) + ,g))) + +; Would like to write a faster case based on table generated by a macro, +; but can't insert objects into expansions in Mzscheme. + +(mac caselet (var expr . args) + (let ex (afn (args) + (if (no (cdr args)) + (car args) + `(if (is ,var ',(car args)) + ,(cadr args) + ,(self (cddr args))))) + `(let ,var ,expr ,(ex args)))) + +(mac case (expr . args) + `(caselet ,(uniq) ,expr ,@args)) + +(mac push (x place) + (w/uniq gx + (let (binds val setter) (setforms place) + `(let ,gx ,x + (atwiths ,binds + (,setter (cons ,gx ,val))))))) + +(mac swap (place1 place2) + (w/uniq (g1 g2) + (with ((binds1 val1 setter1) (setforms place1) + (binds2 val2 setter2) (setforms place2)) + `(atwiths ,(+ binds1 (list g1 val1) binds2 (list g2 val2)) + (,setter1 ,g2) + (,setter2 ,g1))))) + +(mac rotate places + (with (vars (map [uniq] places) + forms (map setforms places)) + `(atwiths ,(mappend (fn (g (binds val setter)) + (+ binds (list g val))) + vars + forms) + ,@(map (fn (g (binds val setter)) + (list setter g)) + (+ (cdr vars) (list (car vars))) + forms)))) + +(mac pop (place) + (w/uniq g + (let (binds val setter) (setforms place) + `(atwiths ,(+ binds (list g val)) + (do1 (car ,g) + (,setter (cdr ,g))))))) + +(def adjoin (x xs (o test iso)) + (if (some [test x _] xs) + xs + (cons x xs))) + +(mac pushnew (x place . args) + (w/uniq gx + (let (binds val setter) (setforms place) + `(atwiths ,(+ (list gx x) binds) + (,setter (adjoin ,gx ,val ,@args)))))) + +(mac pull (test place) + (w/uniq g + (let (binds val setter) (setforms place) + `(atwiths ,(+ (list g test) binds) + (,setter (rem ,g ,val)))))) + +(mac togglemem (x place . args) + (w/uniq gx + (let (binds val setter) (setforms place) + `(atwiths ,(+ (list gx x) binds) + (,setter (if (mem ,gx ,val) + (rem ,gx ,val) + (adjoin ,gx ,val ,@args))))))) + +(mac ++ (place (o i 1)) + (if (isa place 'sym) + `(= ,place (+ ,place ,i)) + (w/uniq gi + (let (binds val setter) (setforms place) + `(atwiths ,(+ binds (list gi i)) + (,setter (+ ,val ,gi))))))) + +(mac -- (place (o i 1)) + (if (isa place 'sym) + `(= ,place (- ,place ,i)) + (w/uniq gi + (let (binds val setter) (setforms place) + `(atwiths ,(+ binds (list gi i)) + (,setter (- ,val ,gi))))))) + +; E.g. (++ x) equiv to (zap + x 1) + +(mac zap (op place . args) + (with (gop (uniq) + gargs (map [uniq] args) + mix (afn seqs + (if (some no seqs) + nil + (+ (map car seqs) + (apply self (map cdr seqs)))))) + (let (binds val setter) (setforms place) + `(atwiths ,(+ binds (list gop op) (mix gargs args)) + (,setter (,gop ,val ,@gargs)))))) + +; Can't simply mod pr to print strings represented as lists of chars, +; because empty string will get printed as nil. Would need to rep strings +; as lists of chars annotated with 'string, and modify car and cdr to get +; the rep of these. That would also require hacking the reader. + +(def pr args + (map1 disp args) + (car args)) + +(def prt args + (map1 [if _ (disp _)] args) + (car args)) + +(def prn args + (do1 (apply pr args) + (writec #\newline))) + +(mac wipe args + `(do ,@(map (fn (a) `(= ,a nil)) args))) + +(mac set args + `(do ,@(map (fn (a) `(= ,a t)) args))) + +; Destructuring means ambiguity: are pat vars bound in else? (no) + +(mac iflet (var expr then . rest) + (w/uniq gv + `(let ,gv ,expr + (if ,gv (let ,var ,gv ,then) ,@rest)))) + +(mac whenlet (var expr . body) + `(iflet ,var ,expr (do ,@body))) + +(mac aif (expr . body) + `(let it ,expr + (if it + ,@(if (cddr body) + `(,(car body) (aif ,@(cdr body))) + body)))) + +(mac awhen (expr . body) + `(let it ,expr (if it (do ,@body)))) + +(mac aand args + (if (no args) + 't + (no (cdr args)) + (car args) + `(let it ,(car args) (and it (aand ,@(cdr args)))))) + +(mac accum (accfn . body) + (w/uniq gacc + `(withs (,gacc nil ,accfn [push _ ,gacc]) + ,@body + (rev ,gacc)))) + +; Repeatedly evaluates its body till it returns nil, then returns vals. + +(mac drain (expr (o eof nil)) + (w/uniq (gacc gdone gres) + `(with (,gacc nil ,gdone nil) + (while (no ,gdone) + (let ,gres ,expr + (if (is ,gres ,eof) + (= ,gdone t) + (push ,gres ,gacc)))) + (rev ,gacc)))) + +; For the common C idiom while x = snarfdata != stopval. +; Rename this if use it often. + +(mac whiler (var expr endval . body) + (w/uniq gf + `(withs (,var nil ,gf (testify ,endval)) + (while (no (,gf (= ,var ,expr))) + ,@body)))) + +;(def macex (e) +; (if (atom e) +; e +; (let op (and (atom (car e)) (eval (car e))) +; (if (isa op 'mac) +; (apply (rep op) (cdr e)) +; e)))) + +(def consif (x y) (if x (cons x y) y)) + +(def string args + (apply + "" (map [coerce _ 'string] args))) + +(def flat x + ((afn (x acc) + (if (no x) acc + (atom x) (cons x acc) + (self (car x) (self (cdr x) acc)))) + x nil)) + +(mac check (x test (o alt)) + (w/uniq gx + `(let ,gx ,x + (if (,test ,gx) ,gx ,alt)))) + +(def pos (test seq (o start 0)) + (let f (testify test) + (if (alist seq) + ((afn (seq n) + (if (no seq) + nil + (f (car seq)) + n + (self (cdr seq) (+ n 1)))) + (nthcdr start seq) + start) + (recstring [if (f (seq _)) _] seq start)))) + +(def even (n) (is (mod n 2) 0)) + +(def odd (n) (no (even n))) + +(mac after (x . ys) + `(protect (fn () ,x) (fn () ,@ys))) + +(let expander + (fn (f var name body) + `(let ,var (,f ,name) + (after (do ,@body) (close ,var)))) + + (mac w/infile (var name . body) + (expander 'infile var name body)) + + (mac w/outfile (var name . body) + (expander 'outfile var name body)) + + (mac w/instring (var str . body) + (expander 'instring var str body)) + + (mac w/socket (var port . body) + (expander 'open-socket var port body)) + ) + +(mac w/outstring (var . body) + `(let ,var (outstring) ,@body)) + +; what happens to a file opened for append if arc is killed in +; the middle of a write? + +(mac w/appendfile (var name . body) + `(let ,var (outfile ,name 'append) + (after (do ,@body) (close ,var)))) + +; rename this simply "to"? - prob not; rarely use + +(mac w/stdout (str . body) + `(call-w/stdout ,str (fn () ,@body))) + +(mac w/stdin (str . body) + `(call-w/stdin ,str (fn () ,@body))) + +(mac tostring body + (w/uniq gv + `(w/outstring ,gv + (w/stdout ,gv ,@body) + (inside ,gv)))) + +(mac fromstring (str . body) + (w/uniq gv + `(w/instring ,gv ,str + (w/stdin ,gv ,@body)))) + +(def readstring1 (s (o eof nil)) (w/instring i s (read i eof))) + +(def read ((o x (stdin)) (o eof nil)) + (if (isa x 'string) (readstring1 x eof) (sread x eof))) + +; inconsistency between names of readfile[1] and writefile + +(def readfile (name) (w/infile s name (drain (read s)))) + +(def readfile1 (name) (w/infile s name (read s))) + +(def readall (src (o eof nil)) + ((afn (i) + (let x (read i eof) + (if (is x eof) + nil + (cons x (self i))))) + (if (isa src 'string) (instring src) src))) + +(def allchars (str) + (tostring (whiler c (readc str nil) no + (writec c)))) + +(def filechars (name) + (w/infile s name (allchars s))) + +(def writefile (val file) + (let tmpfile (+ file ".tmp") + (w/outfile o tmpfile (write val o)) + (mvfile tmpfile file)) + val) + +(def sym (x) (coerce x 'sym)) + +(def int (x (o b 10)) (coerce x 'int b)) + +(mac rand-choice exprs + `(case (rand ,(len exprs)) + ,@(let key -1 + (mappend [list (++ key) _] + exprs)))) + +(mac n-of (n expr) + (w/uniq ga + `(let ,ga nil + (repeat ,n (push ,expr ,ga)) + (rev ,ga)))) + +; rejects bytes >= 248 lest digits be overrepresented + +(def rand-string (n) + (let c "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + (with (nc 62 s (newstring n) i 0) + (w/infile str "/dev/urandom" + (while (< i n) + (let x (readb str) + (unless (> x 247) + (= (s i) (c (mod x nc))) + (++ i))))) + s))) + +(mac forlen (var s . body) + `(for ,var 0 (- (len ,s) 1) ,@body)) + +(mac on (var s . body) + (if (is var 'index) + (err "Can't use index as first arg to on.") + (w/uniq gs + `(let ,gs ,s + (forlen index ,gs + (let ,var (,gs index) + ,@body)))))) + +(def best (f seq) + (if (no seq) + nil + (let wins (car seq) + (each elt (cdr seq) + (if (f elt wins) (= wins elt))) + wins))) + +(def max args (best > args)) +(def min args (best < args)) + +; (mac max2 (x y) +; (w/uniq (a b) +; `(with (,a ,x ,b ,y) (if (> ,a ,b) ,a ,b)))) + +(def most (f seq) + (unless (no seq) + (withs (wins (car seq) topscore (f wins)) + (each elt (cdr seq) + (let score (f elt) + (if (> score topscore) (= wins elt topscore score)))) + wins))) + +; Insert so that list remains sorted. Don't really want to expose +; these but seem to have to because can't include a fn obj in a +; macroexpansion. + +(def insert-sorted (test elt seq) + (if (no seq) + (list elt) + (test elt (car seq)) + (cons elt seq) + (cons (car seq) (insert-sorted test elt (cdr seq))))) + +(mac insort (test elt seq) + `(zap [insert-sorted ,test ,elt _] ,seq)) + +(def reinsert-sorted (test elt seq) + (if (no seq) + (list elt) + (is elt (car seq)) + (reinsert-sorted test elt (cdr seq)) + (test elt (car seq)) + (cons elt (rem elt seq)) + (cons (car seq) (reinsert-sorted test elt (cdr seq))))) + +(mac insortnew (test elt seq) + `(zap [reinsert-sorted ,test ,elt _] ,seq)) + +; Could make this look at the sig of f and return a fn that took the +; right no of args and didn't have to call apply (or list if 1 arg). + +(def memo (f) + (with (cache (table) nilcache (table)) + (fn args + (or (cache args) + (and (no (nilcache args)) + (aif (apply f args) + (= (cache args) it) + (do (set (nilcache args)) + nil))))))) + + +(mac defmemo (name parms . body) + `(safeset ,name (memo (fn ,parms ,@body)))) + +(def <= args + (or (no args) + (no (cdr args)) + (and (no (> (car args) (cadr args))) + (apply <= (cdr args))))) + +(def >= args + (or (no args) + (no (cdr args)) + (and (no (< (car args) (cadr args))) + (apply >= (cdr args))))) + +(def whitec (c) + (in c #\space #\newline #\tab #\return)) + +(def nonwhite (c) (no (whitec c))) + +(def letter (c) (or (<= #\a c #\z) (<= #\A c #\Z))) + +(def digit (c) (<= #\0 c #\9)) + +(def alphadig (c) (or (letter c) (digit c))) + +(def punc (c) + (in c #\. #\, #\; #\: #\! #\?)) + +(def readline ((o str (stdin))) + (awhen (readc str) + (tostring + (writec it) + (whiler c (readc str) [in _ nil #\newline] + (writec c))))) + +; Don't currently use this but suspect some code could. + +(mac summing (sumfn . body) + (w/uniq (gc gt) + `(let ,gc 0 + (let ,sumfn (fn (,gt) (if ,gt (++ ,gc))) + ,@body) + ,gc))) + +(def sum (f xs) + (let n 0 + (each x xs (++ n (f x))) + n)) + +(def treewise (f base tree) + (if (atom tree) + (base tree) + (f (treewise f base (car tree)) + (treewise f base (cdr tree))))) + +(def carif (x) (if (atom x) x (car x))) + +; Could prob be generalized beyond printing. + +(def prall (elts (o init "") (o sep ", ")) + (when elts + (pr init (car elts)) + (map [pr sep _] (cdr elts)) + elts)) + +(def prs args + (prall args "" #\space)) + +(def tree-subst (old new tree) + (if (is tree old) + new + (atom tree) + tree + (cons (tree-subst old new (car tree)) + (tree-subst old new (cdr tree))))) + +(def ontree (f tree) + (f tree) + (unless (atom tree) + (ontree f (car tree)) + (ontree f (cdr tree)))) + +(def dotted (x) + (if (atom x) + nil + (and (cdr x) (or (atom (cdr x)) + (dotted (cdr x)))))) + +(def fill-table (table data) + (each (k v) (pair data) (= (table k) v)) + table) + +(def keys (h) + (accum a (each (k v) h (a k)))) + +(def vals (h) + (accum a (each (k v) h (a v)))) + +; These two should really be done by coerce. Wrap coerce? + +(def tablist (h) + (accum a (maptable (fn args (a args)) h))) + +(def listtab (al) + (let h (table) + (map (fn ((k v)) (= (h k) v)) + al) + h)) + +(mac obj args + `(listtab (list ,@(map (fn ((k v)) + `(list ',k ,v)) + (pair args))))) + +(def load-table (file (o eof)) + (w/infile i file (read-table i eof))) + +(def read-table ((o i (stdin)) (o eof)) + (let e (read i eof) + (if (alist e) (listtab e) e))) + +(def load-tables (file) + (w/infile i file + (w/uniq eof + (drain (read-table i eof) eof)))) + +(def save-table (h file) + (writefile (tablist h) file)) + +(def write-table (h (o o (stdout))) + (write (tablist h) o)) + +(def copy (x . args) + (let x2 (case (type x) + sym x + cons (copylist x) ; (apply (fn args args) x) + string (let new (newstring (len x)) + (forlen i x + (= (new i) (x i))) + new) + table (let new (table) + (each (k v) x + (= (new k) v)) + new) + (err "Can't copy " x)) + (map (fn ((k v)) (= (x2 k) v)) + (pair args)) + x2)) + +(def abs (n) + (if (< n 0) (- n) n)) + +; The problem with returning a list instead of multiple values is that +; you can't act as if the fn didn't return multiple vals in cases where +; you only want the first. Not a big problem. + +(def round (n) + (withs (base (trunc n) rem (abs (- n base))) + (if (> rem 1/2) ((if (> n 0) + -) base 1) + (< rem 1/2) base + (odd base) ((if (> n 0) + -) base 1) + base))) + +(def roundup (n) + (withs (base (trunc n) rem (abs (- n base))) + (if (>= rem 1/2) + ((if (> n 0) + -) base 1) + base))) + +(def nearest (n quantum) + (* (roundup (/ n quantum)) quantum)) + +(def avg (ns) (/ (apply + ns) (len ns))) + +(def med (ns (o test >)) + ((sort test ns) (round (/ (len ns) 2)))) + +; Use mergesort on assumption that mostly sorting mostly sorted lists +; benchmark: (let td (n-of 10000 (rand 100)) (time (sort < td)) 1) + +(def sort (test seq) + (if (alist seq) + (mergesort test (copy seq)) + (coerce (mergesort test (coerce seq 'cons)) (type seq)))) + +; Destructive stable merge-sort, adapted from slib and improved +; by Eli Barzilay for MzLib; re-written in Arc. + +(def mergesort (less? lst) + (with (n (len lst)) + (if (<= n 1) lst + ; ; check if the list is already sorted + ; ; (which can be a common case, eg, directory lists). + ; (let loop ([last (car lst)] [next (cdr lst)]) + ; (or (null? next) + ; (and (not (less? (car next) last)) + ; (loop (car next) (cdr next))))) + ; lst + ((afn (n) + (if (> n 2) + ; needs to evaluate L->R + (withs (j (/ (if (even n) n (- n 1)) 2) ; faster than round + a (self j) + b (self (- n j))) + (merge less? a b)) + ; the following case just inlines the length 2 case, + ; it can be removed (and use the above case for n>1) + ; and the code still works, except a little slower + (is n 2) + (with (x (car lst) y (cadr lst) p lst) + (= lst (cddr lst)) + (when (less? y x) (scar p y) (scar (cdr p) x)) + (scdr (cdr p) nil) + p) + (is n 1) + (with (p lst) + (= lst (cdr lst)) + (scdr p nil) + p) + nil)) + n)))) + +; Also by Eli. + +(def merge (less? x y) + (if (no x) y + (no y) x + (let lup nil + (assign lup + (fn (r x y r-x?) ; r-x? for optimization -- is r connected to x? + (if (less? (car y) (car x)) + (do (if r-x? (scdr r y)) + (if (cdr y) (lup y x (cdr y) nil) (scdr y x))) + ; (car x) <= (car y) + (do (if (no r-x?) (scdr r x)) + (if (cdr x) (lup x (cdr x) y t) (scdr x y)))))) + (if (less? (car y) (car x)) + (do (if (cdr y) (lup y x (cdr y) nil) (scdr y x)) + y) + ; (car x) <= (car y) + (do (if (cdr x) (lup x (cdr x) y t) (scdr x y)) + x))))) + +(def bestn (n f seq) + (firstn n (sort f seq))) + +(def split (seq pos) + (list (cut seq 0 pos) (cut seq pos))) + +(mac time (expr) + (w/uniq (t1 t2) + `(let ,t1 (msec) + (do1 ,expr + (let ,t2 (msec) + (prn "time: " (- ,t2 ,t1) " msec.")))))) + +(mac jtime (expr) + `(do1 'ok (time ,expr))) + +(mac time10 (expr) + `(time (repeat 10 ,expr))) + +(def union (f xs ys) + (+ xs (rem (fn (y) (some [f _ y] xs)) + ys))) + +(= templates* (table)) + +(mac deftem (tem . fields) + (withs (name (carif tem) includes (if (acons tem) (cdr tem))) + `(= (templates* ',name) + (+ (mappend templates* ',(rev includes)) + (list ,@(map (fn ((k v)) `(list ',k (fn () ,v))) + (pair fields))))))) + +(mac addtem (name . fields) + `(= (templates* ',name) + (union (fn (x y) (is (car x) (car y))) + (list ,@(map (fn ((k v)) `(list ',k (fn () ,v))) + (pair fields))) + (templates* ',name)))) + +(def inst (tem . args) + (let x (table) + (each (k v) (if (acons tem) tem (templates* tem)) + (unless (no v) (= (x k) (v)))) + (each (k v) (pair args) + (= (x k) v)) + x)) + +; To write something to be read by temread, (write (tablist x)) + +(def temread (tem (o str (stdin))) + (templatize tem (read str))) + +; Converts alist to inst; ugly; maybe should make this part of coerce. +; Note: discards fields not defined by the template. + +(def templatize (tem raw) + (with (x (inst tem) fields (if (acons tem) tem (templates* tem))) + (each (k v) raw + (when (assoc k fields) + (= (x k) v))) + x)) + +(def temload (tem file) + (w/infile i file (temread tem i))) + +(def temloadall (tem file) + (map (fn (pairs) (templatize tem pairs)) + (w/infile in file (readall in)))) + + +(def number (n) (in (type n) 'int 'num)) + +(def since (t1) (- (seconds) t1)) + +(def minutes-since (t1) (/ (since t1) 60)) +(def hours-since (t1) (/ (since t1) 3600)) +(def days-since (t1) (/ (since t1) 86400)) + +; could use a version for fns of 1 arg at least + +(def cache (timef valf) + (with (cached nil gentime nil) + (fn () + (unless (and cached (< (since gentime) (timef))) + (= cached (valf) + gentime (seconds))) + cached))) + +(mac defcache (name lasts . body) + `(safeset ,name (cache (fn () ,lasts) + (fn () ,@body)))) + +(mac errsafe (expr) + `(on-err (fn (c) nil) + (fn () ,expr))) + +(def saferead (arg) (errsafe:read arg)) + +(def safe-load-table (filename) + (or (errsafe:load-table filename) + (table))) + +(def ensure-dir (path) + (unless (dir-exists path) + (system (string "mkdir -p " path)))) + +(def date ((o s (seconds))) + (rev (nthcdr 3 (timedate s)))) + +(def datestring ((o s (seconds))) + (let (y m d) (date s) + (string y "-" (if (< m 10) "0") m "-" (if (< d 10) "0") d))) + +(def count (test x) + (with (n 0 testf (testify test)) + (each elt x + (if (testf elt) (++ n))) + n)) + +(def ellipsize (str (o limit 80)) + (if (<= (len str) limit) + str + (+ (cut str 0 limit) "..."))) + +(def rand-elt (seq) + (seq (rand (len seq)))) + +(mac until (test . body) + `(while (no ,test) ,@body)) + +(def before (x y seq (o i 0)) + (with (xp (pos x seq i) yp (pos y seq i)) + (and xp (or (no yp) (< xp yp))))) + +(def orf fns + (fn args + ((afn (fs) + (and fs (or (apply (car fs) args) (self (cdr fs))))) + fns))) + +(def andf fns + (fn args + ((afn (fs) + (if (no fs) t + (no (cdr fs)) (apply (car fs) args) + (and (apply (car fs) args) (self (cdr fs))))) + fns))) + +(def atend (i s) + (> i (- (len s) 2))) + +(def multiple (x y) + (is 0 (mod x y))) + +(mac nor args `(no (or ,@args))) + +; Consider making the default sort fn take compare's two args (when do +; you ever have to sort mere lists of numbers?) and rename current sort +; as prim-sort or something. + +; Could simply modify e.g. > so that (> len) returned the same thing +; as (compare > len). + +(def compare (comparer scorer) + (fn (x y) (comparer (scorer x) (scorer y)))) + +; Cleaner thus, but may only ever need in 2 arg case. + +;(def compare (comparer scorer) +; (fn args (apply comparer map scorer args))) + +; (def only (f g . args) (aif (apply g args) (f it))) + +(def only (f) + (fn args (if (car args) (apply f args)))) + +(mac conswhen (f x y) + (w/uniq (gf gx) + `(with (,gf ,f ,gx ,x) + (if (,gf ,gx) (cons ,gx ,y) ,y)))) + +; Could combine with firstn if put f arg last, default to (fn (x) t). + +(def retrieve (n f xs) + (if (no n) (keep f xs) + (or (<= n 0) (no xs)) nil + (f (car xs)) (cons (car xs) (retrieve (- n 1) f (cdr xs))) + (retrieve n f (cdr xs)))) + +(def dedup (xs) + (with (h (table) acc nil) + (each x xs + (unless (h x) + (push x acc) + (set (h x)))) + (rev acc))) + +(def single (x) (and (acons x) (no (cdr x)))) + +(def intersperse (x ys) + (and ys (cons (car ys) + (mappend [list x _] (cdr ys))))) + +(def counts (seq (o c (table))) + (if (no seq) + c + (do (++ (c (car seq) 0)) + (counts (cdr seq) c)))) + +(def commonest (seq) + (with (winner nil n 0) + (each (k v) (counts seq) + (when (> v n) (= winner k n v))) + (list winner n))) + +(def reduce (f xs) + (if (cddr xs) + (reduce f (cons (f (car xs) (cadr xs)) (cddr xs))) + (apply f xs))) + +(def rreduce (f xs) + (if (cddr xs) + (f (car xs) (rreduce f (cdr xs))) + (apply f xs))) + +(let argsym (uniq) + + (def parse-format (str) + (accum a + (with (chars nil i -1) + (w/instring s str + (whilet c (readc s) + (case c + #\# (do (a (coerce (rev chars) 'string)) + (wipe chars) + (a (read s))) + #\~ (do (a (coerce (rev chars) 'string)) + (wipe chars) + (readc s) + (a (list argsym (++ i)))) + (push c chars)))) + (when chars + (a (coerce (rev chars) 'string)))))) + + (mac prf (str . args) + `(let ,argsym (list ,@args) + (pr ,@(parse-format str)))) +) + +(def load (file) + (w/infile f file + (w/uniq eof + (whiler e (read f eof) eof + (eval e))))) + +(def positive (x) + (and (number x) (> x 0))) + +(mac w/table (var . body) + `(let ,var (table) ,@body ,var)) + +(def ero args + (w/stdout (stderr) + (each a args + (write a) + (writec #\space)) + (writec #\newline)) + (car args)) + +(def queue () (list nil nil 0)) + +; Despite call to atomic, once had some sign this wasn't thread-safe. +; Keep an eye on it. + +(def enq (obj q) + (atomic + (++ (q 2)) + (if (no (car q)) + (= (cadr q) (= (car q) (list obj))) + (= (cdr (cadr q)) (list obj) + (cadr q) (cdr (cadr q)))) + (car q))) + +(def deq (q) + (atomic (unless (is (q 2) 0) (-- (q 2))) + (pop (car q)))) + +; Should redef len to do this, and make queues lists annotated queue. + +(def qlen (q) (q 2)) + +(def qlist (q) (car q)) + +(def enq-limit (val q (o limit 1000)) + (atomic + (unless (< (qlen q) limit) + (deq q)) + (enq val q))) + +(def median (ns) + ((sort > ns) (trunc (/ (len ns) 2)))) + +(mac noisy-each (n var val . body) + (w/uniq (gn gc) + `(with (,gn ,n ,gc 0) + (each ,var ,val + (when (multiple (++ ,gc) ,gn) + (pr ".") + (flushout) + ) + ,@body) + (prn) + (flushout)))) + +(mac point (name . body) + (w/uniq (g p) + `(ccc (fn (,g) + (let ,name (fn ((o ,p)) (,g ,p)) + ,@body))))) + +(mac catch body + `(point throw ,@body)) + +(def downcase (x) + (let downc (fn (c) + (let n (coerce c 'int) + (if (or (< 64 n 91) (< 191 n 215) (< 215 n 223)) + (coerce (+ n 32) 'char) + c))) + (case (type x) + string (map downc x) + char (downc x) + sym (sym (map downc (coerce x 'string))) + (err "Can't downcase" x)))) + +(def upcase (x) + (let upc (fn (c) + (let n (coerce c 'int) + (if (or (< 96 n 123) (< 223 n 247) (< 247 n 255)) + (coerce (- n 32) 'char) + c))) + (case (type x) + string (map upc x) + char (upc x) + sym (sym (map upc (coerce x 'string))) + (err "Can't upcase" x)))) + +(def inc (x (o n 1)) + (coerce (+ (coerce x 'int) n) (type x))) + +(def range (start end) + (if (> start end) + nil + (cons start (range (inc start) end)))) + +(def mismatch (s1 s2) + (catch + (on c s1 + (when (isnt c (s2 index)) + (throw index))))) + +(def memtable (ks) + (let h (table) + (each k ks (set (h k))) + h)) + +(= bar* " | ") + +(mac w/bars body + (w/uniq (out needbars) + `(let ,needbars nil + (do ,@(map (fn (e) + `(let ,out (tostring ,e) + (unless (is ,out "") + (if ,needbars + (pr bar* ,out) + (do (set ,needbars) + (pr ,out)))))) + body))))) + +(def len< (x n) (< (len x) n)) + +(def len> (x n) (> (len x) n)) + +(mac thread body + `(new-thread (fn () ,@body))) + +(mac trav (x . fs) + (w/uniq g + `((afn (,g) + (when ,g + ,@(map [list _ g] fs))) + ,x))) + +(mac or= (place expr) + (let (binds val setter) (setforms place) + `(atwiths ,binds + (or ,val (,setter ,expr))))) + +(= hooks* (table)) + +(def hook (name . args) + (aif (hooks* name) (apply it args))) + +(mac defhook (name . rest) + `(= (hooks* ',name) (fn ,@rest))) + +(mac out (expr) `(pr ,(tostring (eval expr)))) + +; if renamed this would be more natural for (map [_ user] pagefns*) + +(def get (index) [_ index]) + +(= savers* (table)) + +(mac fromdisk (var file init load save) + (w/uniq (gf gv) + `(unless (bound ',var) + (do1 (= ,var (iflet ,gf (file-exists ,file) + (,load ,gf) + ,init)) + (= (savers* ',var) (fn (,gv) (,save ,gv ,file))))))) + +(mac diskvar (var file) + `(fromdisk ,var ,file nil readfile1 writefile)) + +(mac disktable (var file) + `(fromdisk ,var ,file (table) load-table save-table)) + +(mac todisk (var (o expr var)) + `((savers* ',var) + ,(if (is var expr) var `(= ,var ,expr)))) + + +(mac evtil (expr test) + (w/uniq gv + `(let ,gv ,expr + (while (no (,test ,gv)) + (= ,gv ,expr)) + ,gv))) + +(def rand-key (h) + (if (empty h) + nil + (let n (rand (len h)) + (catch + (each (k v) h + (when (is (-- n) -1) + (throw k))))))) + +(def ratio (test xs) + (if (empty xs) + 0 + (/ (count test xs) (len xs)))) + + +; any logical reason I can't say (push x (if foo y z)) ? +; eval would have to always ret 2 things, the val and where it came from +; idea: implicit tables of tables; setf empty field, becomes table +; or should setf on a table just take n args? + +; idea: use constants in functional position for currying? +; (1 foo) would mean (fn args (apply foo 1 args)) +; another solution would be to declare certain symbols curryable, and +; if > was, >_10 would mean [> _ 10] +; or just say what the hell and make _ ssyntax for currying +; idea: make >10 ssyntax for [> _ 10] +; solution to the "problem" of improper lists: allow any atom as a list +; terminator, not just nil. means list recursion should terminate on +; atom rather than nil, (def empty (x) (or (atom x) (is x ""))) +; table should be able to take an optional initial-value. handle in sref. +; warn about code of form (if (= )) -- probably mean is +; warn when a fn has a parm that's already defined as a macro. +; (def foo (after) (after)) +; idea: a fn (nothing) that returns a special gensym which is ignored +; by map, so can use map in cases when don't want all the vals +; idea: anaph macro so instead of (aand x y) say (anaph and x y) +; idea: foo.bar!baz as an abbrev for (foo bar 'baz) +; or something a bit more semantic? +; could uniq be (def uniq () (annotate 'symbol (list 'u))) again? +; idea: use x- for (car x) and -x for (cdr x) (but what about math -?) +; idea: get rid of strings and just use symbols +; could a string be (#\a #\b . "") ? +; better err msg when , outside of a bq +; idea: parameter (p foo) means in body foo is (pair arg) +; idea: make ('string x) equiv to (coerce x 'string) ? or isa? +; quoted atoms in car valuable unused semantic space +; idea: if (defun foo (x y) ...), make (foo 1) return (fn (y) (foo 1 y)) +; probably would lead to lots of errors when call with missing args +; but would be really dense with . notation, (foo.1 2) +; or use special ssyntax for currying: (foo@1 2) +; remember, can also double; could use foo::bar to mean something +; wild idea: inline defs for repetitive code +; same args as fn you're in +; variant of compose where first fn only applied to first arg? +; (> (len x) y) means (>+len x y) +; use ssyntax underscore for a var? +; foo_bar means [foo _ bar] +; what does foo:_:bar mean? +; matchcase +; idea: atable that binds it to table, assumes input is a list +; crazy that finding the top 100 nos takes so long: +; (let bb (n-of 1000 (rand 50)) (time10 (bestn 100 > bb))) +; time: 2237 msec. -> now down to 850 msec + @@ -0,0 +1,16 @@ +; mzscheme -m -f as.scm +; (tl) +; (asv) +; http://localhost:8080 + +(require mzscheme) ; promise we won't redefine mzscheme bindings + +(require "ac.scm") +(require "brackets.scm") +(use-bracket-readtable) + +(aload "arc.arc") +(aload "libs.arc") + +(tl) + diff --git a/blog.arc b/blog.arc new file mode 100644 index 0000000..211dd63 --- /dev/null +++ b/blog.arc @@ -0,0 +1,95 @@ +; 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/brackets.scm b/brackets.scm new file mode 100644 index 0000000..fa52a53 --- /dev/null +++ b/brackets.scm @@ -0,0 +1,48 @@ +; From Eli Barzilay, eli@barzilay.org + +;> (require "brackets.scm") +;> (use-bracket-readtable) +;> ([+ _ 1] 10) +;11 + +(module brackets mzscheme + +; main reader function for []s +; recursive read starts with default readtable's [ parser, +; but nested reads still use the curent readtable: + +(define (read-square-brackets ch port src line col pos) + `(fn (_) + ,(read/recursive port #\[ #f))) + +; a readtable that is just like the builtin except for []s + +(define bracket-readtable + (make-readtable #f #\[ 'terminating-macro read-square-brackets)) + +; call this to set the global readtable + +(provide use-bracket-readtable) + +(define (use-bracket-readtable) + (current-readtable bracket-readtable)) + +; these two implement the required functionality for #reader + +;(define (*read inp) +; (parameterize ((current-readtable bracket-readtable)) +; (read inp))) + +(define (*read . args) + (parameterize ((current-readtable bracket-readtable)) + (read (if (null? args) (current-input-port) (car args))))) + +(define (*read-syntax src port) + (parameterize ((current-readtable bracket-readtable)) + (read-syntax src port))) + +; and the need to be provided as `read' and `read-syntax' + +(provide (rename *read read) (rename *read-syntax read-syntax)) + +) diff --git a/code.arc b/code.arc new file mode 100644 index 0000000..cf1e280 --- /dev/null +++ b/code.arc @@ -0,0 +1,61 @@ +; Code analysis. Spun off 21 Dec 07. + +; Ought to do more of this in Arc. One of the biggest advantages +; of Lisp is messing with code. + +(def codelines (file) + (w/infile in file + (summing test + (whilet line (readline in) + (test (aand (find nonwhite line) (isnt it #\;))))))) + +(def codeflat (file) + (len (flat (readall (infile file))))) + +(def codetree (file) + (treewise + (fn (x) 1) (readall (infile file)))) + +(def code-density (file) + (/ (codetree file) (codelines file))) + +(def tokcount (files) + (let counts (table) + (each f files + (each token (flat (readall (infile f))) + (++ (counts token 0)))) + counts)) + +(def common-tokens (files) + (let counts (tokcount files) + (let ranking nil + (maptable (fn (k v) + (unless (nonop k) + (insort (compare > cadr) (list k v) ranking))) + counts) + ranking))) + +(def nonop (x) + (in x 'quote 'unquote 'quasiquote 'unquote-splicing)) + +(def common-operators (files) + (keep [and (isa (car _) 'sym) (bound (car _))] (common-tokens files))) + +(def top40 (xs) + (map prn (firstn 40 xs)) + t) + +(def space-eaters (files) + (let counts (tokcount files) + (let ranking nil + (maptable (fn (k v) + (when (and (isa k 'sym) (bound k)) + (insort (compare > [* (len (string (car _))) + (cadr _)]) + (list k v (* (len (string k)) v)) + ranking))) + counts) + ranking))) + +;(top40 (space-eaters allfiles*)) + +(mac flatlen args `(len (flat ',args))) diff --git a/copyright b/copyright new file mode 100644 index 0000000..c608ea0 --- /dev/null +++ b/copyright @@ -0,0 +1,2 @@ +This software is copyright (c) Paul Graham and Robert Morris. Permission +to use it is granted under the Perl Foundations's Artistic License 2.0. diff --git a/how-to-run-news b/how-to-run-news new file mode 100644 index 0000000..dae9db7 --- /dev/null +++ b/how-to-run-news @@ -0,0 +1,44 @@ +To run News: + +tar xvf arc3.1.tar + +cd arc3.1 + +mkdir arc + +echo "myname" > arc/admins + +mzscheme -f as.scm + +at the arc prompt: + +(load "news.arc") + +(nsv) + +go to http://localhost:8080 + +click on login, and create an account called myname + +you should now be logged in as an admin + +manually give at least 10 karma to your initial set of users + +don't worry about "user break" messages when restarting News + + + +To customize News: + +change the variables at the top of news.arc + + + +To improve performance: + +(= static-max-age* 7200) ; browsers can cache static files for 7200 sec + +(declare 'direct-calls t) ; you promise not to redefine fns as tables + +(declare 'explicit-flush t) ; you take responsibility for flushing output + ; (all existing news code already does) diff --git a/html.arc b/html.arc new file mode 100644 index 0000000..981dfaa --- /dev/null +++ b/html.arc @@ -0,0 +1,415 @@ +; HTML Utils. + + +(def color (r g b) + (with (c (table) + f (fn (x) (if (< x 0) 0 (> x 255) 255 x))) + (= (c 'r) (f r) (c 'g) (f g) (c 'b) (f b)) + c)) + +(def dehex (str) (errsafe (coerce str 'int 16))) + +(defmemo hex>color (str) + (and (is (len str) 6) + (with (r (dehex (cut str 0 2)) + g (dehex (cut str 2 4)) + b (dehex (cut str 4 6))) + (and r g b + (color r g b))))) + +(defmemo gray (n) (color n n n)) + +(= white (gray 255) + black (gray 0) + linkblue (color 0 0 190) + orange (color 255 102 0) + darkred (color 180 0 0) + darkblue (color 0 0 120) + ) + +(= opmeths* (table)) + +(mac opmeth args + `(opmeths* (list ,@args))) + +(mac attribute (tag opt f) + `(= (opmeths* (list ',tag ',opt)) ,f)) + +(= hexreps (table)) + +(for i 0 255 (= (hexreps i) + (let s (coerce i 'string 16) + (if (is (len s) 1) (+ "0" s) s)))) + +(defmemo hexrep (col) + (+ (hexreps (col 'r)) (hexreps (col 'g)) (hexreps (col 'b)))) + +(def opcolor (key val) + (w/uniq gv + `(whenlet ,gv ,val + (pr ,(string " " key "=#") (hexrep ,gv))))) + +(def opstring (key val) + `(aif ,val (pr ,(+ " " key "=\"") it #\"))) + +(def opnum (key val) + `(aif ,val (pr ,(+ " " key "=") it))) + +(def opsym (key val) + `(pr ,(+ " " key "=") ,val)) + +(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 "=\"")) + (if (isa it 'string) (pr-escaped it) (pr it)) + (pr #\"))) + +; need to escape more? =? + +(def pr-escaped (x) + (each c x + (pr (case c #\< "<" + #\> ">" + #\" """ + #\& "&" + c)))) + +(attribute a href opstring) +(attribute a rel opstring) +(attribute a class opstring) +(attribute a id opsym) +(attribute a onclick opstring) +(attribute body alink opcolor) +(attribute body bgcolor opcolor) +(attribute body leftmargin opnum) +(attribute body link opcolor) +(attribute body marginheight opnum) +(attribute body marginwidth opnum) +(attribute body topmargin opnum) +(attribute body vlink opcolor) +(attribute font color opcolor) +(attribute font face opstring) +(attribute font size opnum) +(attribute form action opstring) +(attribute form method opsym) +(attribute img align opsym) +(attribute img border opnum) +(attribute img height opnum) +(attribute img width opnum) +(attribute img vspace opnum) +(attribute img hspace opnum) +(attribute img src opstring) +(attribute input name opstring) +(attribute input size opnum) +(attribute input type opsym) +(attribute input value opesc) +(attribute input checked opcheck) +(attribute select name opstring) +(attribute option selected opsel) +(attribute table bgcolor opcolor) +(attribute table border opnum) +(attribute table cellpadding opnum) +(attribute table cellspacing opnum) +(attribute table width opstring) +(attribute textarea cols opnum) +(attribute textarea name opstring) +(attribute textarea rows opnum) +(attribute textarea wrap opsym) +(attribute td align opsym) +(attribute td bgcolor opcolor) +(attribute td colspan opnum) +(attribute td width opnum) +(attribute td valign opsym) +(attribute td class opstring) +(attribute tr bgcolor opcolor) +(attribute hr color opcolor) +(attribute span class opstring) +(attribute span align opstring) +(attribute span id opsym) +(attribute rss version opstring) + + +(mac gentag args (start-tag args)) + +(mac tag (spec . body) + `(do ,(start-tag spec) + ,@body + ,(end-tag spec))) + +(mac tag-if (test spec . body) + `(if ,test + (tag ,spec ,@body) + (do ,@body))) + +(def start-tag (spec) + (if (atom spec) + `(pr ,(string "<" spec ">")) + (let opts (tag-options (car spec) (pair (cdr spec))) + (if (all [isa _ 'string] opts) + `(pr ,(string "<" (car spec) (apply string opts) ">")) + `(do (pr ,(string "<" (car spec))) + ,@(map (fn (opt) + (if (isa opt 'string) + `(pr ,opt) + opt)) + opts) + (pr ">")))))) + +(def end-tag (spec) + `(pr ,(string "</" (carif spec) ">"))) + +(def literal (x) + (case (type x) + sym (in x nil t) + cons (caris x 'quote) + t)) + +; Returns a list whose elements are either strings, which can +; simply be printed out, or expressions, which when evaluated +; generate output. + +(def tag-options (spec options) + (if (no options) + '() + (let ((opt val) . rest) options + (let meth (if (is opt 'style) opstring (opmeth spec opt)) + (if meth + (if val + (cons (if (precomputable-tagopt val) + (tostring (eval (meth opt val))) + (meth opt val)) + (tag-options spec rest)) + (tag-options spec rest)) + (do + (pr "<!-- ignoring " opt " for " spec "-->") + (tag-options spec rest))))))) + +(def precomputable-tagopt (val) + (and (literal val) + (no (and (is (type val) 'string) (find #\@ val))))) + +(def br ((o n 1)) + (repeat n (pr "<br>")) + (prn)) + +(def br2 () (prn "<br><br>")) + +(mac center body `(tag center ,@body)) +(mac underline body `(tag u ,@body)) +(mac tab body `(tag (table border 0) ,@body)) +(mac tr body `(tag tr ,@body)) + +(let pratoms (fn (body) + (if (or (no body) + (all [and (acons _) (isnt (car _) 'quote)] + body)) + body + `((pr ,@body)))) + + (mac td body `(tag td ,@(pratoms body))) + (mac trtd body `(tr (td ,@(pratoms body)))) + (mac tdr body `(tag (td align 'right) ,@(pratoms body))) + (mac tdcolor (col . body) `(tag (td bgcolor ,col) ,@(pratoms body))) +) + +(mac row args + `(tr ,@(map [list 'td _] args))) + +(mac prrow args + (w/uniq g + `(tr ,@(map (fn (a) + `(let ,g ,a + (if (number ,g) + (tdr (pr ,g)) + (td (pr ,g))))) + args)))) + +(mac prbold body `(tag b (pr ,@body))) + +(def para args + (gentag p) + (when args (apply pr args))) + +(def menu (name items (o sel nil)) + (tag (select name name) + (each i items + (tag (option selected (is i sel)) + (pr i))))) + +(mac whitepage body + `(tag html + (tag (body bgcolor white alink linkblue) ,@body))) + +(def errpage args (whitepage (apply prn args))) + +(def blank-url () "s.gif") + +; Could memoize these. + +; If h = 0, doesn't affect table column widths in some Netscapes. + +(def hspace (n) (gentag img src (blank-url) height 1 width n)) +(def vspace (n) (gentag img src (blank-url) height n width 0)) +(def vhspace (h w) (gentag img src (blank-url) height h width w)) + +(mac new-hspace (n) + (if (number n) + `(pr ,(string "<span style=\"padding-left:" n "px\" />")) + `(pr "<span style=\"padding-left:" ,n "px\" />"))) + +;(def spacerow (h) (tr (td (vspace h)))) + +(def spacerow (h) (pr "<tr style=\"height:" h "px\"></tr>")) + +; For use as nested table. + +(mac zerotable body + `(tag (table border 0 cellpadding 0 cellspacing 0) + ,@body)) + +; was `(tag (table border 0 cellpadding 0 cellspacing 7) ,@body) + +(mac sptab body + `(tag (table style "border-spacing: 7px 0px;") ,@body)) + +(mac widtable (w . body) + `(tag (table width ,w) (tr (td ,@body)))) + +(def cellpr (x) (pr (or x " "))) + +(def but ((o text "submit") (o name nil)) + (gentag input type 'submit name name value text)) + +(def submit ((o val "submit")) + (gentag input type 'submit value val)) + +(def buts (name . texts) + (if (no texts) + (but) + (do (but (car texts) name) + (each text (cdr texts) + (pr " ") + (but text name))))) + +(mac spanrow (n . body) + `(tr (tag (td colspan ,n) ,@body))) + +(mac form (action . body) + `(tag (form method "post" action ,action) ,@body)) + +(mac textarea (name rows cols . body) + `(tag (textarea name ,name rows ,rows cols ,cols) ,@body)) + +(def input (name (o val "") (o size 10)) + (gentag input type 'text name name value val size size)) + +(mac inputs args + `(tag (table border 0) + ,@(map (fn ((name label len text)) + (w/uniq (gl gt) + `(let ,gl ,len + (tr (td (pr ',label ":")) + (if (isa ,gl 'cons) + (td (textarea ',name (car ,gl) (cadr ,gl) + (let ,gt ,text (if ,gt (pr ,gt))))) + (td (gentag input type ',(if (is label 'password) + 'password + 'text) + name ',name + size ,len + value ,text))))))) + (tuples args 4)))) + +(def single-input (label name chars btext (o pwd)) + (pr label) + (gentag input type (if pwd 'password 'text) name name size chars) + (sp) + (submit btext)) + +(mac cdata body + `(do (pr "<![CDATA[") + ,@body + (pr "]]>"))) + +(def eschtml (str) + (tostring + (each c str + (pr (case c #\< "<" + #\> ">" + #\" """ + #\' "'" + #\& "&" + c))))) + +(def esc-tags (str) + (tostring + (each c str + (pr (case c #\< "<" + #\> ">" + #\& "&" + c))))) + +(def nbsp () (pr " ")) + +(def link (text (o dest text) (o color)) + (tag (a href dest) + (tag-if color (font color color) + (pr text)))) + +(def underlink (text (o dest text)) + (tag (a href dest) (tag u (pr text)))) + +(def striptags (s) + (let intag nil + (tostring + (each c s + (if (is c #\<) (set intag) + (is c #\>) (wipe intag) + (no intag) (pr c)))))) + +(def clean-url (u) + (rem [in _ #\" #\' #\< #\>] u)) + +(def shortlink (url) + (unless (or (no url) (< (len url) 7)) + (link (cut url 7) url))) + +; this should be one regexp + +(def parafy (str) + (let ink nil + (tostring + (each c str + (pr c) + (unless (whitec c) (set ink)) + (when (is c #\newline) + (unless ink (pr "<p>")) + (wipe ink)))))) + +(mac spanclass (name . body) + `(tag (span class ',name) ,@body)) + +(def pagemessage (text) + (when text (prn text) (br2))) + +; Could be stricter. Memoized because looking for chars in Unicode +; strings is terribly inefficient in Mzscheme. + +(defmemo valid-url (url) + (and (len> url 10) + (or (begins url "http://") + (begins url "https://")) + (~find [in _ #\< #\> #\" #\'] url))) + +(mac fontcolor (c . body) + (w/uniq g + `(let ,g ,c + (if ,g + (tag (font color ,g) ,@body) + (do ,@body))))) diff --git a/libs.arc b/libs.arc new file mode 100644 index 0000000..68b5d9b --- /dev/null +++ b/libs.arc @@ -0,0 +1,7 @@ +(map load '("strings.arc" + "pprint.arc" + "code.arc" + "html.arc" + "srv.arc" + "app.arc" + "prompt.arc")) diff --git a/news.arc b/news.arc new file mode 100644 index 0000000..e837d64 --- /dev/null +++ b/news.arc @@ -0,0 +1,2617 @@ +; News. 2 Sep 06. + +; to run news: (nsv), then go to http://localhost:8080 +; put usernames of admins, separated by whitespace, in arc/admins + +; bug: somehow (+ votedir* nil) is getting evaluated. + +(declare 'atstrings t) + +(= this-site* "My Forum" + site-url* "http://news.yourdomain.com/" + parent-url* "http://www.yourdomain.com" + favicon-url* "" + site-desc* "What this site is about." ; for rss feed + site-color* (color 180 180 180) + border-color* (color 180 180 180) + prefer-url* t) + + +; Structures + +; Could add (html) types like choice, yesno to profile fields. But not +; as part of deftem, which is defstruct. Need another mac on top of +; deftem. Should not need the type specs in user-fields. + +(deftem profile + id nil + name nil + created (seconds) + auth 0 + member nil + submitted nil + votes nil ; for now just recent, elts each (time id by sitename dir) + karma 1 + avg nil + weight .5 + ignore nil + email nil + about nil + showdead nil + noprocrast nil + firstview nil + lastview nil + maxvisit 20 + minaway 180 + topcolor nil + keys nil + delay 0) + +(deftem item + id nil + type nil + by nil + ip nil + time (seconds) + url nil + title nil + text nil + votes nil ; elts each (time ip user type score) + score 0 + sockvotes 0 + flags nil + dead nil + deleted nil + parts nil + parent nil + kids nil + keys nil) + + +; Load and Save + +(= newsdir* "arc/news/" + storydir* "arc/news/story/" + profdir* "arc/news/profile/" + votedir* "arc/news/vote/") + +(= votes* (table) profs* (table)) + +(= initload-users* nil) + +(def nsv ((o port 8080)) + (map ensure-dir (list arcdir* newsdir* storydir* votedir* profdir*)) + (unless stories* (load-items)) + (if (and initload-users* (empty profs*)) (load-users)) + (asv port)) + +(def load-users () + (pr "load users: ") + (noisy-each 100 id (dir profdir*) + (load-user id))) + +; For some reason vote files occasionally get written out in a +; broken way. The nature of the errors (random missing or extra +; chars) suggests the bug is lower-level than anything in Arc. +; Which unfortunately means all lists written to disk are probably +; vulnerable to it, since that's all save-table does. + +(def load-user (u) + (= (votes* u) (load-table (+ votedir* u)) + (profs* u) (temload 'profile (+ profdir* u))) + u) + +; Have to check goodname because some user ids come from http requests. +; So this is like safe-item. Don't need a sep fn there though. + +(def profile (u) + (or (profs* u) + (aand (goodname u) + (file-exists (+ profdir* u)) + (= (profs* u) (temload 'profile it))))) + +(def votes (u) + (or (votes* u) + (aand (file-exists (+ votedir* u)) + (= (votes* u) (load-table it))))) + +(def init-user (u) + (= (votes* u) (table) + (profs* u) (inst 'profile 'id u)) + (save-votes u) + (save-prof u) + u) + +; Need this because can create users on the server (for other apps) +; without setting up places to store their state as news users. +; See the admin op in app.arc. So all calls to login-page from the +; news app need to call this in the after-login fn. + +(def ensure-news-user (u) + (if (profile u) u (init-user u))) + +(def save-votes (u) (save-table (votes* u) (+ votedir* u))) + +(def save-prof (u) (save-table (profs* u) (+ profdir* u))) + +(mac uvar (u k) `((profile ,u) ',k)) + +(mac karma (u) `(uvar ,u karma)) +(mac ignored (u) `(uvar ,u ignore)) + +; Note that users will now only consider currently loaded users. + +(def users ((o f idfn)) + (keep f (keys profs*))) + +(def check-key (u k) + (and u (mem k (uvar u keys)))) + +(def author (u i) (is u i!by)) + + +(= stories* nil comments* nil + items* (table) url->story* (table) + maxid* 0 initload* 15000) + +; The dir expression yields stories in order of file creation time +; (because arc infile truncates), so could just rev the list instead of +; sorting, but sort anyway. + +; Note that stories* etc only include the initloaded (i.e. recent) +; ones, plus those created since this server process started. + +; Could be smarter about preloading by keeping track of popular pages. + +(def load-items () + (system (+ "rm " storydir* "*.tmp")) + (pr "load items: ") + (with (items (table) + ids (sort > (map int (dir storydir*)))) + (if ids (= maxid* (car ids))) + (noisy-each 100 id (firstn initload* ids) + (let i (load-item id) + (push i (items i!type)))) + (= stories* (rev (merge (compare < !id) items!story items!poll)) + comments* (rev items!comment)) + (hook 'initload items)) + (ensure-topstories)) + +(def ensure-topstories () + (aif (errsafe (readfile1 (+ newsdir* "topstories"))) + (= ranked-stories* (map item it)) + (do (prn "ranking stories.") + (flushout) + (gen-topstories)))) + +(def astory (i) (is i!type 'story)) +(def acomment (i) (is i!type 'comment)) +(def apoll (i) (is i!type 'poll)) + +(def load-item (id) + (let i (temload 'item (+ storydir* id)) + (= (items* id) i) + (awhen (and (astory&live i) (check i!url ~blank)) + (register-url i it)) + i)) + +; Note that duplicates are only prevented of items that have at some +; point been loaded. + +(def register-url (i url) + (= (url->story* (canonical-url url)) i!id)) + +; redefined later + +(= stemmable-sites* (table)) + +(def canonical-url (url) + (if (stemmable-sites* (sitename url)) + (cut url 0 (pos #\? url)) + url)) + +(def new-item-id () + (evtil (++ maxid*) [~file-exists (+ storydir* _)])) + +(def item (id) + (or (items* id) (errsafe:load-item id))) + +(def kids (i) (map item i!kids)) + +; For use on external item references (from urls). Checks id is int +; because people try e.g. item?id=363/blank.php + +(def safe-item (id) + (ok-id&item (if (isa id 'string) (saferead id) id))) + +(def ok-id (id) + (and (exact id) (<= 1 id maxid*))) + +(def arg->item (req key) + (safe-item:saferead (arg req key))) + +(def live (i) (nor i!dead i!deleted)) + +(def save-item (i) (save-table i (+ storydir* i!id))) + +(def kill (i how) + (unless i!dead + (log-kill i how) + (wipe (comment-cache* i!id)) + (set i!dead) + (save-item i))) + +(= kill-log* nil) + +(def log-kill (i how) + (push (list i!id how) kill-log*)) + +(mac each-loaded-item (var . body) + (w/uniq g + `(let ,g nil + (loop (= ,g maxid*) (> ,g 0) (-- ,g) + (whenlet ,var (items* ,g) + ,@body))))) + +(def loaded-items (test) + (accum a (each-loaded-item i (test&a i)))) + +(def newslog args (apply srvlog 'news args)) + + +; Ranking + +; Votes divided by the age in hours to the gravityth power. +; Would be interesting to scale gravity in a slider. + +(= gravity* 1.8 timebase* 120 front-threshold* 1 + nourl-factor* .4 lightweight-factor* .3 ) + +(def frontpage-rank (s (o scorefn realscore) (o gravity gravity*)) + (* (/ (let base (- (scorefn s) 1) + (if (> base 0) (expt base .8) base)) + (expt (/ (+ (item-age s) timebase*) 60) gravity)) + (if (no (in s!type 'story 'poll)) .5 + (blank s!url) nourl-factor* + (lightweight s) (min lightweight-factor* + (contro-factor s)) + (contro-factor s)))) + +(def contro-factor (s) + (aif (check (visible-family nil s) [> _ 20]) + (min 1 (expt (/ (realscore s) it) 2)) + 1)) + +(def realscore (i) (- i!score i!sockvotes)) + +(disktable lightweights* (+ newsdir* "lightweights")) + +(def lightweight (s) + (or s!dead + (mem 'rally s!keys) ; title is a rallying cry + (mem 'image s!keys) ; post is mainly image(s) + (lightweights* (sitename s!url)) + (lightweight-url s!url))) + +(defmemo lightweight-url (url) + (in (downcase (last (tokens url #\.))) "png" "jpg" "jpeg")) + +(def item-age (i) (minutes-since i!time)) + +(def user-age (u) (minutes-since (uvar u created))) + +; Only looks at the 1000 most recent stories, which might one day be a +; problem if there is massive spam. + +(def gen-topstories () + (= ranked-stories* (rank-stories 180 1000 (memo frontpage-rank)))) + +(def save-topstories () + (writefile (map !id (firstn 180 ranked-stories*)) + (+ newsdir* "topstories"))) + +(def rank-stories (n consider scorefn) + (bestn n (compare > scorefn) (latest-items metastory nil consider))) + +; With virtual lists the above call to latest-items could be simply: +; (map item (retrieve consider metastory:item (gen maxid* [- _ 1]))) + +(def latest-items (test (o stop) (o n)) + (accum a + (catch + (down id maxid* 1 + (let i (item id) + (if (or (and stop (stop i)) (and n (<= n 0))) + (throw)) + (when (test i) + (a i) + (if n (-- n)))))))) + +; redefined later + +(def metastory (i) (and i (in i!type 'story 'poll))) + +(def adjust-rank (s (o scorefn frontpage-rank)) + (insortnew (compare > (memo scorefn)) s ranked-stories*) + (save-topstories)) + +; If something rose high then stopped getting votes, its score would +; decline but it would stay near the top. Newly inserted stories would +; thus get stuck in front of it. I avoid this by regularly adjusting +; the rank of a random top story. + +(defbg rerank-random 30 (rerank-random)) + +(def rerank-random () + (when ranked-stories* + (adjust-rank (ranked-stories* (rand (min 50 (len ranked-stories*))))))) + +(def topstories (user n (o threshold front-threshold*)) + (retrieve n + [and (>= (realscore _) threshold) (cansee user _)] + ranked-stories*)) + +(= max-delay* 10) + +(def cansee (user i) + (if i!deleted (admin user) + i!dead (or (author user i) (seesdead user)) + (delayed i) (author user i) + t)) + +(let mature (table) + (def delayed (i) + (and (no (mature i!id)) + (acomment i) + (or (< (item-age i) (min max-delay* (uvar i!by delay))) + (do (set (mature i!id)) + nil))))) + +(def seesdead (user) + (or (and user (uvar user showdead) (no (ignored user))) + (editor user))) + +(def visible (user is) + (keep [cansee user _] is)) + +(def cansee-descendant (user c) + (or (cansee user c) + (some [cansee-descendant user (item _)] + c!kids))) + +(def editor (u) + (and u (or (admin u) (> (uvar u auth) 0)))) + +(def member (u) + (and u (or (admin u) (uvar u member)))) + + +; Page Layout + +(= up-url* "grayarrow.gif" down-url* "graydown.gif" logo-url* "arc.png") + +(defopr favicon.ico req favicon-url*) + +; redefined later + +(def gen-css-url () + (prn "<link rel=\"stylesheet\" type=\"text/css\" href=\"news.css\">")) + +(mac npage (title . body) + `(tag html + (tag head + (gen-css-url) + (prn "<link rel=\"shortcut icon\" href=\"" favicon-url* "\">") + (tag script (pr votejs*)) + (tag title (pr ,title))) + (tag body + (center + (tag (table border 0 cellpadding 0 cellspacing 0 width "85%" + bgcolor sand) + ,@body))))) + +(= pagefns* nil) + +(mac fulltop (user lid label title whence . body) + (w/uniq (gu gi gl gt gw) + `(with (,gu ,user ,gi ,lid ,gl ,label ,gt ,title ,gw ,whence) + (npage (+ this-site* (if ,gt (+ bar* ,gt) "")) + (if (check-procrast ,gu) + (do (pagetop 'full ,gi ,gl ,gt ,gu ,gw) + (hook 'page ,gu ,gl) + ,@body) + (row (procrast-msg ,gu ,gw))))))) + +(mac longpage (user t1 lid label title whence . body) + (w/uniq (gu gt gi) + `(with (,gu ,user ,gt ,t1 ,gi ,lid) + (fulltop ,gu ,gi ,label ,title ,whence + (trtd ,@body) + (trtd (vspace 10) + (color-stripe (main-color ,gu)) + (br) + (center + (hook 'longfoot) + (admin-bar ,gu (- (msec) ,gt) ,whence))))))) + +(def admin-bar (user elapsed whence) + (when (admin user) + (br2) + (w/bars + (pr (len items*) "/" maxid* " loaded") + (pr (round (/ (memory) 1000000)) " mb") + (pr elapsed " msec") + (link "settings" "newsadmin") + (hook 'admin-bar user whence)))) + +(def color-stripe (c) + (tag (table width "100%" cellspacing 0 cellpadding 1) + (tr (tdcolor c)))) + +(mac shortpage (user lid label title whence . body) + `(fulltop ,user ,lid ,label ,title ,whence + (trtd ,@body))) + +(mac minipage (label . body) + `(npage (+ this-site* bar* ,label) + (pagetop nil nil ,label) + (trtd ,@body))) + +(def msgpage (user msg (o title)) + (minipage (or title "Message") + (spanclass admin + (center (if (len> msg 80) + (widtable 500 msg) + (pr msg)))) + (br2))) + +(= (max-age* 'news.css) 86400) ; cache css in browser for 1 day + +; turn off server caching via (= caching* 0) or won't see changes + +(defop news.css req + (pr " +body { font-family:Verdana; font-size:10pt; color:#828282; } +td { font-family:Verdana; font-size:10pt; color:#828282; } + +.admin td { font-family:Verdana; font-size:8.5pt; color:#000000; } +.subtext td { font-family:Verdana; font-size: 7pt; color:#828282; } + +input { font-family:Courier; font-size:10pt; color:#000000; } +input[type=\"submit\"] { font-family:Verdana; } +textarea { font-family:Courier; font-size:10pt; color:#000000; } + +a:link { color:#000000; text-decoration:none; } +a:visited { color:#828282; text-decoration:none; } + +.default { font-family:Verdana; font-size: 10pt; color:#828282; } +.admin { font-family:Verdana; font-size:8.5pt; color:#000000; } +.title { font-family:Verdana; font-size: 10pt; color:#828282; } +.adtitle { font-family:Verdana; font-size: 9pt; color:#828282; } +.subtext { font-family:Verdana; font-size: 7pt; color:#828282; } +.yclinks { font-family:Verdana; font-size: 8pt; color:#828282; } +.pagetop { font-family:Verdana; font-size: 10pt; color:#222222; } +.comhead { font-family:Verdana; font-size: 8pt; color:#828282; } +.comment { font-family:Verdana; font-size: 9pt; } +.dead { font-family:Verdana; font-size: 9pt; color:#dddddd; } + +.comment a:link, .comment a:visited { text-decoration:underline;} +.dead a:link, .dead a:visited { color:#dddddd; } +.pagetop a:visited { color:#000000;} +.topsel a:link, .topsel a:visited { color:#ffffff; } + +.subtext a:link, .subtext a:visited { color:#828282; } +.subtext a:hover { text-decoration:underline; } + +.comhead a:link, .subtext a:visited { color:#828282; } +.comhead a:hover { text-decoration:underline; } + +.default p { margin-top: 8px; margin-bottom: 0px; } + +.pagebreak {page-break-before:always} + +pre { overflow: auto; padding: 2px; max-width:600px; } +pre:hover {overflow:auto} ")) + +; only need pre padding because of a bug in Mac Firefox + +; Without setting the bottom margin of p tags to 0, 1- and n-para comments +; have different space at the bottom. This solution suggested by Devin. +; Really am using p tags wrong (as separators rather than wrappers) and the +; correct thing to do would be to wrap each para in <p></p>. Then whatever +; I set the bottom spacing to, it would be the same no matter how many paras +; in a comment. In this case by setting the bottom spacing of p to 0, I'm +; making it the same as no p, which is what the first para has. + +; supplied by pb +;.vote { padding-left:2px; vertical-align:top; } +;.comment { margin-top:1ex; margin-bottom:1ex; color:black; } +;.vote IMG { border:0; margin: 3px 2px 3px 2px; } +;.reply { font-size:smaller; text-decoration:underline !important; } + +(= votejs* " +function byId(id) { + return document.getElementById(id); +} + +function vote(node) { + var v = node.id.split(/_/); // {'up', '123'} + var item = v[1]; + + // adjust score + var score = byId('score_' + item); + var newscore = parseInt(score.innerHTML) + (v[0] == 'up' ? 1 : -1); + score.innerHTML = newscore + (newscore == 1 ? ' point' : ' points'); + + // hide arrows + byId('up_' + item).style.visibility = 'hidden'; + byId('down_' + item).style.visibility = 'hidden'; + + // ping server + var ping = new Image(); + ping.src = node.href; + + return false; // cancel browser nav +} ") + + +; Page top + +(= sand (color 246 246 239) textgray (gray 130)) + +(def main-color (user) + (aif (and user (uvar user topcolor)) + (hex>color it) + site-color*)) + +(def pagetop (switch lid label (o title) (o user) (o whence)) +; (tr (tdcolor black (vspace 5))) + (tr (tdcolor (main-color user) + (tag (table border 0 cellpadding 0 cellspacing 0 width "100%" + style "padding:2px") + (tr (gen-logo) + (when (is switch 'full) + (tag (td style "line-height:12pt; height:10px;") + (spanclass pagetop + (tag b (link this-site* "news")) + (hspace 10) + (toprow user label)))) + (if (is switch 'full) + (tag (td style "text-align:right;padding-right:4px;") + (spanclass pagetop (topright user whence))) + (tag (td style "line-height:12pt; height:10px;") + (spanclass pagetop (prbold label)))))))) + (map [_ user] pagefns*) + (spacerow 10)) + +(def gen-logo () + (tag (td style "width:18px;padding-right:4px") + (tag (a href parent-url*) + (tag (img src logo-url* width 18 height 18 + style "border:1px #@(hexrep border-color*) solid;"))))) + +(= toplabels* '(nil "welcome" "new" "threads" "comments" "leaders" "*")) + +; redefined later + +(= welcome-url* "welcome") + +(def toprow (user label) + (w/bars + (when (noob user) + (toplink "welcome" welcome-url* label)) + (toplink "new" "newest" label) + (when user + (toplink "threads" (threads-url user) label)) + (toplink "comments" "newcomments" label) + (toplink "leaders" "leaders" label) + (hook 'toprow user label) + (link "submit") + (unless (mem label toplabels*) + (fontcolor white (pr label))))) + +(def toplink (name dest label) + (tag-if (is name label) (span class 'topsel) + (link name dest))) + +(def topright (user whence (o showkarma t)) + (when user + (userlink user user nil) + (when showkarma (pr " (@(karma user))")) + (pr " | ")) + (if user + (rlinkf 'logout (req) + (when-umatch/r user req + (logout-user user) + whence)) + (onlink "login" + (login-page 'both nil + (list (fn (u ip) + (ensure-news-user u) + (newslog ip u 'top-login)) + whence))))) + +(def noob (user) + (and user (< (days-since (uvar user created)) 1))) + + +; News-Specific Defop Variants + +(mac defopt (name parm test msg . body) + `(defop ,name ,parm + (if (,test (get-user ,parm)) + (do ,@body) + (login-page 'both (+ "Please log in" ,msg ".") + (list (fn (u ip) (ensure-news-user u)) + (string ',name (reassemble-args ,parm))))))) + +(mac defopg (name parm . body) + `(defopt ,name ,parm idfn "" ,@body)) + +(mac defope (name parm . body) + `(defopt ,name ,parm editor " as an editor" ,@body)) + +(mac defopa (name parm . body) + `(defopt ,name ,parm admin " as an administrator" ,@body)) + +(mac opexpand (definer name parms . body) + (w/uniq gr + `(,definer ,name ,gr + (with (user (get-user ,gr) ip (,gr 'ip)) + (with ,(and parms (mappend [list _ (list 'arg gr (string _))] + parms)) + (newslog ip user ',name ,@parms) + ,@body))))) + +(= newsop-names* nil) + +(mac newsop args + `(do (pushnew ',(car args) newsop-names*) + (opexpand defop ,@args))) + +(mac adop (name parms . body) + (w/uniq g + `(opexpand defopa ,name ,parms + (let ,g (string ',name) + (shortpage user nil ,g ,g ,g + ,@body))))) + +(mac edop (name parms . body) + (w/uniq g + `(opexpand defope ,name ,parms + (let ,g (string ',name) + (shortpage user nil ,g ,g ,g + ,@body))))) + + +; News Admin + +(defopa newsadmin req + (let user (get-user req) + (newslog req!ip user 'newsadmin) + (newsadmin-page user))) + +; Note that caching* is reset to val in source when restart server. + +(def nad-fields () + `((num caching ,caching* t t) + (bigtoks comment-kill ,comment-kill* t t) + (bigtoks comment-ignore ,comment-ignore* t t) + (bigtoks lightweights ,(sort < (keys lightweights*)) t t))) + +; Need a util like vars-form for a collection of variables. +; Or could generalize vars-form to think of places (in the setf sense). + +(def newsadmin-page (user) + (shortpage user nil nil "newsadmin" "newsadmin" + (vars-form user + (nad-fields) + (fn (name val) + (case name + caching (= caching* val) + comment-kill (todisk comment-kill* val) + comment-ignore (todisk comment-ignore* val) + lightweights (todisk lightweights* (memtable val)) + )) + (fn () (newsadmin-page user))) + (br2) + (aform (fn (req) + (with (user (get-user req) subject (arg req "id")) + (if (profile subject) + (do (killallby subject) + (submitted-page user subject)) + (admin&newsadmin-page user)))) + (single-input "" 'id 20 "kill all by")) + (br2) + (aform (fn (req) + (let user (get-user req) + (set-ip-ban user (arg req "ip") t) + (admin&newsadmin-page user))) + (single-input "" 'ip 20 "ban ip")))) + + +; Users + +(newsop user (id) + (if (only.profile id) + (user-page user id) + (pr "No such user."))) + +(def user-page (user subject) + (let here (user-url subject) + (shortpage user nil nil (+ "Profile: " subject) here + (profile-form user subject) + (br2) + (when (some astory:item (uvar subject submitted)) + (underlink "submissions" (submitted-url subject))) + (when (some acomment:item (uvar subject submitted)) + (sp) + (underlink "comments" (threads-url subject))) + (hook 'user user subject)))) + +(def profile-form (user subject) + (let prof (profile subject) + (vars-form user + (user-fields user subject) + (fn (name val) + (when (and (is name 'ignore) val (no prof!ignore)) + (log-ignore user subject 'profile)) + (= (prof name) val)) + (fn () (save-prof subject) + (user-page user subject))))) + +(= topcolor-threshold* 250) + +(def user-fields (user subject) + (withs (e (editor user) + a (admin user) + w (is user subject) + k (and w (> (karma user) topcolor-threshold*)) + u (or a w) + m (or a (and (member user) w)) + p (profile subject)) + `((string user ,subject t nil) + (string name ,(p 'name) ,m ,m) + (string created ,(text-age:user-age subject) t nil) + (string password ,(resetpw-link) ,w nil) + (string saved ,(saved-link user subject) ,u nil) + (int auth ,(p 'auth) ,e ,a) + (yesno member ,(p 'member) ,a ,a) + (posint karma ,(p 'karma) t ,a) + (num avg ,(p 'avg) ,a nil) + (yesno ignore ,(p 'ignore) ,e ,e) + (num weight ,(p 'weight) ,a ,a) + (mdtext2 about ,(p 'about) t ,u) + (string email ,(p 'email) ,u ,u) + (yesno showdead ,(p 'showdead) ,u ,u) + (yesno noprocrast ,(p 'noprocrast) ,u ,u) + (string firstview ,(p 'firstview) ,a nil) + (string lastview ,(p 'lastview) ,a nil) + (posint maxvisit ,(p 'maxvisit) ,u ,u) + (posint minaway ,(p 'minaway) ,u ,u) + (sexpr keys ,(p 'keys) ,a ,a) + (hexcol topcolor ,(or (p 'topcolor) (hexrep site-color*)) ,k ,k) + (int delay ,(p 'delay) ,u ,u)))) + +(def saved-link (user subject) + (when (or (admin user) (is user subject)) + (let n (if (len> (votes subject) 500) + "many" + (len (voted-stories user subject))) + (if (is n 0) + "" + (tostring (underlink n (saved-url subject))))))) + +(def resetpw-link () + (tostring (underlink "reset password" "resetpw"))) + +(newsop welcome () + (pr "Welcome to " this-site* ", " user "!")) + + +; Main Operators + +; remember to set caching to 0 when testing non-logged-in + +(= caching* 1 perpage* 30 threads-perpage* 10 maxend* 210) + +; Limiting that newscache can't take any arguments except the user. +; To allow other arguments, would have to turn the cache from a single +; stored value to a hash table whose keys were lists of arguments. + +(mac newscache (name user time . body) + (w/uniq gc + `(let ,gc (cache (fn () (* caching* ,time)) + (fn () (tostring (let ,user nil ,@body)))) + (def ,name (,user) + (if ,user + (do ,@body) + (pr (,gc))))))) + + +(newsop news () (newspage user)) + +(newsop || () (newspage user)) + +;(newsop index.html () (newspage user)) + +(newscache newspage user 90 + (listpage user (msec) (topstories user maxend*) nil nil "news")) + +(def listpage (user t1 items label title (o url label) (o number t)) + (hook 'listpage user) + (longpage user t1 nil label title url + (display-items user items label title url 0 perpage* number))) + + +(newsop newest () (newestpage user)) + +; Note: dead/deleted items will persist for the remaining life of the +; cached page. If this were a prob, could make deletion clear caches. + +(newscache newestpage user 40 + (listpage user (msec) (newstories user maxend*) "new" "New Links" "newest")) + +(def newstories (user n) + (retrieve n [cansee user _] stories*)) + + +(newsop best () (bestpage user)) + +(newscache bestpage user 1000 + (listpage user (msec) (beststories user maxend*) "best" "Top Links")) + +; As no of stories gets huge, could test visibility in fn sent to best. + +(def beststories (user n) + (bestn n (compare > realscore) (visible user stories*))) + + +(newsop noobstories () (noobspage user stories*)) +(newsop noobcomments () (noobspage user comments*)) + +(def noobspage (user source) + (listpage user (msec) (noobs user maxend* source) "noobs" "New Accounts")) + +(def noobs (user n source) + (retrieve n [and (cansee user _) (bynoob _)] source)) + +(def bynoob (i) + (< (- (user-age i!by) (item-age i)) 2880)) + + +(newsop bestcomments () (bestcpage user)) + +(newscache bestcpage user 1000 + (listpage user (msec) (bestcomments user maxend*) + "best comments" "Best Comments" "bestcomments" nil)) + +(def bestcomments (user n) + (bestn n (compare > realscore) (visible user comments*))) + + +(newsop lists () + (longpage user (msec) nil "lists" "Lists" "lists" + (sptab + (row (link "best") "Highest voted recent links.") + (row (link "active") "Most active current discussions.") + (row (link "bestcomments") "Highest voted recent comments.") + (row (link "noobstories") "Submissions from new accounts.") + (row (link "noobcomments") "Comments from new accounts.") + (when (admin user) + (map row:link + '(optimes topips flagged killed badguys badlogins goodlogins))) + (hook 'listspage user)))) + + +(def saved-url (user) (+ "saved?id=" user)) + +(newsop saved (id) + (if (only.profile id) + (savedpage user id) + (pr "No such user."))) + +(def savedpage (user subject) + (if (or (is user subject) (admin user)) + (listpage user (msec) + (sort (compare < item-age) (voted-stories user subject)) + "saved" "Saved Links" (saved-url subject)) + (pr "Can't display that."))) + +(def voted-stories (user subject) + (keep [and (astory _) (cansee user _)] + (map item (keys:votes subject)))) + + +; Story Display + +(def display-items (user items label title whence + (o start 0) (o end perpage*) (o number)) + (zerotable + (let n start + (each i (cut items start end) + (display-item (and number (++ n)) i user whence t) + (spacerow (if (acomment i) 15 5)))) + (when end + (let newend (+ end perpage*) + (when (and (<= newend maxend*) (< end (len items))) + (spacerow 10) + (tr (tag (td colspan (if number 2 1))) + (tag (td class 'title) + (morelink display-items + items label title end newend number)))))))) + +; This code is inevitably complex because the More fn needs to know +; its own fnid in order to supply a correct whence arg to stuff on +; the page it generates, like logout and delete links. + +(def morelink (f items label title . args) + (tag (a href + (url-for + (afnid (fn (req) + (prn) + (with (url (url-for it) ; it bound by afnid + user (get-user req)) + (newslog req!ip user 'more label) + (longpage user (msec) nil label title url + (apply f user items label title url args)))))) + rel 'nofollow) + (pr "More"))) + +(def display-story (i s user whence) + (when (or (cansee user s) (s 'kids)) + (tr (display-item-number i) + (td (votelinks s user whence)) + (titleline s s!url user whence)) + (tr (tag (td colspan (if i 2 1))) + (tag (td class 'subtext) + (hook 'itemline s user) + (itemline s user) + (when (in s!type 'story 'poll) (commentlink s user)) + (editlink s user) + (when (apoll s) (addoptlink s user)) + (unless i (flaglink s user whence)) + (killlink s user whence) + (blastlink s user whence) + (blastlink s user whence t) + (deletelink s user whence))))) + +(def display-item-number (i) + (when i (tag (td align 'right valign 'top class 'title) + (pr i ".")))) + +(= follow-threshold* 5) + +(def titleline (s url user whence) + (tag (td class 'title) + (if (cansee user s) + (do (deadmark s user) + (titlelink s url user) + (pdflink url) + (awhen (sitename url) + (spanclass comhead + (pr " (" ) + (if (admin user) + (w/rlink (do (set-site-ban user + it + (case (car (banned-sites* it)) + nil 'ignore + ignore 'kill + kill nil)) + whence) + (let ban (car (banned-sites* it)) + (tag-if ban (font color (case ban + ignore darkred + kill darkblue)) + (pr it)))) + (pr it)) + (pr ") ")))) + (pr (pseudo-text s))))) + +(def titlelink (s url user) + (let toself (blank url) + (tag (a href (if toself + (item-url s!id) + (or (live s) (author user s) (editor user)) + url + nil) + rel (unless (or toself (> (realscore s) follow-threshold*)) + 'nofollow)) + (pr s!title)))) + +(def pdflink (url) + (awhen (vacuumize url) + (pr " [") + (link "scribd" it) + (pr "]"))) + +(defmemo vacuumize (url) + (and (or (endmatch ".pdf" url) (endmatch ".PDF" url)) + (+ "http://www.scribd.com/vacuum?url=" url))) + +(def pseudo-text (i) + (if i!deleted "[deleted]" "[dead]")) + +(def deadmark (i user) + (when (and i!dead (seesdead user)) + (pr " [dead] ")) + (when (and i!deleted (admin user)) + (pr " [deleted] "))) + +(= downvote-threshold* 200 downvote-time* 1440) + +(= votewid* 14) + +(def votelinks (i user whence (o downtoo)) + (center + (if (and (cansee user i) + (or (no user) + (no ((votes user) i!id)))) + (do (votelink i user whence 'up) + (if (and downtoo + (or (admin user) + (< (item-age i) downvote-time*)) + (canvote user i 'down)) + (do (br) + (votelink i user whence 'down)) + ; don't understand why needed, but is, or a new + ; page is generated on voting + (tag (span id (+ "down_" i!id))))) + (author user i) + (do (fontcolor orange (pr "*")) + (br) + (hspace votewid*)) + (hspace votewid*)))) + +; could memoize votelink more, esp for non-logged in users, +; since only uparrow is shown; could straight memoize + +; redefined later (identically) so the outs catch new vals of up-url, etc. + +(def votelink (i user whence dir) + (tag (a id (if user (string dir '_ i!id)) + onclick (if user "return vote(this)") + href (vote-url user i dir whence)) + (if (is dir 'up) + (out (gentag img src up-url* border 0 vspace 3 hspace 2)) + (out (gentag img src down-url* border 0 vspace 3 hspace 2))))) + +(def vote-url (user i dir whence) + (+ "vote?" "for=" i!id + "&dir=" dir + (if user (+ "&by=" user "&auth=" (user->cookie* user))) + "&whence=" (urlencode whence))) + +(= lowest-score* -4) + +; Not much stricter than whether to generate the arrow. Further tests +; applied in vote-for. + +(def canvote (user i dir) + (and user + (news-type&live i) + (or (is dir 'up) (> i!score lowest-score*)) + (no ((votes user) i!id)) + (or (is dir 'up) + (and (acomment i) + (> (karma user) downvote-threshold*) + (no (aand i!parent (author user (item it)))))))) + +; Need the by argument or someone could trick logged in users into +; voting something up by clicking on a link. But a bad guy doesn't +; know how to generate an auth arg that matches each user's cookie. + +(newsop vote (by for dir auth whence) + (with (i (safe-item for) + dir (saferead dir) + whence (if whence (urldecode whence) "news")) + (if (no i) + (pr "No such item.") + (no (in dir 'up 'down)) + (pr "Can't make that vote.") + (and by (or (isnt by user) (isnt (sym auth) (user->cookie* user)))) + (pr "User mismatch.") + (no user) + (login-page 'both "You have to be logged in to vote." + (list (fn (u ip) + (ensure-news-user u) + (newslog ip u 'vote-login) + (when (canvote u i dir) + (vote-for u i dir) + (logvote ip u i))) + whence)) + (canvote user i dir) + (do (vote-for by i dir) + (logvote ip by i)) + (pr "Can't make that vote.")))) + +(def itemline (i user) + (when (cansee user i) + (when (news-type i) (itemscore i user)) + (byline i user))) + +(def itemscore (i (o user)) + (tag (span id (+ "score_" i!id)) + (pr (plural (if (is i!type 'pollopt) (realscore i) i!score) + "point"))) + (hook 'itemscore i user)) + +; redefined later + +(def byline (i user) + (pr " by @(tostring (userlink user i!by)) @(text-age:item-age i) ")) + +(def user-url (user) (+ "user?id=" user)) + +(= show-avg* nil) + +(def userlink (user subject (o show-avg t)) + (link (user-name user subject) (user-url subject)) + (awhen (and show-avg* (admin user) show-avg (uvar subject avg)) + (pr " (@(num it 1 t t))"))) + +(= noob-color* (color 60 150 60)) + +(def user-name (user subject) + (if (and (editor user) (ignored subject)) + (tostring (fontcolor darkred (pr subject))) + (and (editor user) (< (user-age subject) 1440)) + (tostring (fontcolor noob-color* (pr subject))) + subject)) + +(= show-threadavg* nil) + +(def commentlink (i user) + (when (cansee user i) + (pr bar*) + (tag (a href (item-url i!id)) + (let n (- (visible-family user i) 1) + (if (> n 0) + (do (pr (plural n "comment")) + (awhen (and show-threadavg* (admin user) (threadavg i)) + (pr " (@(num it 1 t t))"))) + (pr "discuss")))))) + +(def visible-family (user i) + (+ (if (cansee user i) 1 0) + (sum [visible-family user (item _)] i!kids))) + +(def threadavg (i) + (only.avg (map [or (uvar _ avg) 1] + (rem admin (dedup (map !by (keep live (family i)))))))) + +(= user-changetime* 120 editor-changetime* 1440) + +(= everchange* (table) noedit* (table)) + +(def canedit (user i) + (or (admin user) + (and (~noedit* i!type) + (editor user) + (< (item-age i) editor-changetime*)) + (own-changeable-item user i))) + +(def own-changeable-item (user i) + (and (author user i) + (~mem 'locked i!keys) + (no i!deleted) + (or (everchange* i!type) + (< (item-age i) user-changetime*)))) + +(def editlink (i user) + (when (canedit user i) + (pr bar*) + (link "edit" (edit-url i)))) + +(def addoptlink (p user) + (when (or (admin user) (author user p)) + (pr bar*) + (onlink "add choice" (add-pollopt-page p user)))) + +; reset later + +(= flag-threshold* 30 flag-kill-threshold* 7 many-flags* 1) + +; Un-flagging something doesn't unkill it, if it's now no longer +; over flag-kill-threshold. Ok, since arbitrary threshold anyway. + +(def flaglink (i user whence) + (when (and user + (isnt user i!by) + (or (admin user) (> (karma user) flag-threshold*))) + (pr bar*) + (w/rlink (do (togglemem user i!flags) + (when (and (~mem 'nokill i!keys) + (len> i!flags flag-kill-threshold*) + (< (realscore i) 10) + (~find admin:!2 i!vote)) + (kill i 'flags)) + whence) + (pr "@(if (mem user i!flags) 'un)flag")) + (when (and (admin user) (len> i!flags many-flags*)) + (pr bar* (plural (len i!flags) "flag") " ") + (w/rlink (do (togglemem 'nokill i!keys) + (save-item i) + whence) + (pr (if (mem 'nokill i!keys) "un-notice" "noted")))))) + +(def killlink (i user whence) + (when (admin user) + (pr bar*) + (w/rlink (do (zap no i!dead) + (if i!dead + (do (pull 'nokill i!keys) + (log-kill i user)) + (pushnew 'nokill i!keys)) + (save-item i) + whence) + (pr "@(if i!dead 'un)kill")))) + +; Blast kills the submission and bans the user. Nuke also bans the +; site, so that all future submitters will be ignored. Does not ban +; the ip address, but that will eventually get banned by maybe-ban-ip. + +(def blastlink (i user whence (o nuke)) + (when (and (admin user) + (or (no nuke) (~empty i!url))) + (pr bar*) + (w/rlink (do (toggle-blast i user nuke) + whence) + (prt (if (ignored i!by) "un-") (if nuke "nuke" "blast"))))) + +(def toggle-blast (i user (o nuke)) + (atomic + (if (ignored i!by) + (do (wipe i!dead (ignored i!by)) + (awhen (and nuke (sitename i!url)) + (set-site-ban user it nil))) + (do (set i!dead) + (ignore user i!by (if nuke 'nuke 'blast)) + (awhen (and nuke (sitename i!url)) + (set-site-ban user it 'ignore)))) + (if i!dead (log-kill i user)) + (save-item i) + (save-prof i!by))) + +(def candelete (user i) + (or (admin user) (own-changeable-item user i))) + +(def deletelink (i user whence) + (when (candelete user i) + (pr bar*) + (linkf (if i!deleted "undelete" "delete") (req) + (let user (get-user req) + (if (candelete user i) + (del-confirm-page user i whence) + (prn "You can't delete that.")))))) + +; Undeleting stories could cause a slight inconsistency. If a story +; linking to x gets deleted, another submission can take its place in +; url->story. If the original is then undeleted, there will be two +; stories with equal claim to be in url->story. (The more recent will +; win because it happens to get loaded later.) Not a big problem. + +(def del-confirm-page (user i whence) + (minipage "Confirm" + (tab + ; link never used so not testable but think correct + (display-item nil i user (flink [del-confirm-page (get-user _) i whence])) + (spacerow 20) + (tr (td) + (td (urform user req + (do (when (candelete user i) + (= i!deleted (is (arg req "b") "Yes")) + (save-item i)) + whence) + (prn "Do you want this to @(if i!deleted 'stay 'be) deleted?") + (br2) + (but "Yes" "b") (sp) (but "No" "b"))))))) + +(def permalink (story user) + (when (cansee user story) + (pr bar*) + (link "link" (item-url story!id)))) + +(def logvote (ip user story) + (newslog ip user 'vote (story 'id) (list (story 'title)))) + +(def text-age (a) + (tostring + (if (>= a 1440) (pr (plural (trunc (/ a 1440)) "day") " ago") + (>= a 60) (pr (plural (trunc (/ a 60)) "hour") " ago") + (pr (plural (trunc a) "minute") " ago")))) + + +; Voting + +; A user needs legit-threshold karma for a vote to count if there has +; already been a vote from the same IP address. A new account below both +; new- thresholds won't affect rankings, though such votes still affect +; scores unless not a legit-user. + +(= legit-threshold* 0 new-age-threshold* 0 new-karma-threshold* 2) + +(def legit-user (user) + (or (editor user) + (> (karma user) legit-threshold*))) + +(def possible-sockpuppet (user) + (or (ignored user) + (< (uvar user weight) .5) + (and (< (user-age user) new-age-threshold*) + (< (karma user) new-karma-threshold*)))) + +(= downvote-ratio-limit* .65 recent-votes* nil votewindow* 100) + +; Note: if vote-for by one user changes (s 'score) while s is being +; edited by another, the save after the edit will overwrite the change. +; Actual votes can't be lost because that field is not editable. Not a +; big enough problem to drag in locking. + +(def vote-for (user i (o dir 'up)) + (unless (or ((votes user) i!id) + (and (~live i) (isnt user i!by))) + (withs (ip (logins* user) + vote (list (seconds) ip user dir i!score)) + (unless (or (and (or (ignored user) (check-key user 'novote)) + (isnt user i!by)) + (and (is dir 'down) + (~editor user) + (or (check-key user 'nodowns) + (> (downvote-ratio user) downvote-ratio-limit*) + ; prevention of karma-bombing + (just-downvoted user i!by))) + (and (~legit-user user) + (isnt user i!by) + (find [is (cadr _) ip] i!votes)) + (and (isnt i!type 'pollopt) + (biased-voter i vote))) + (++ i!score (case dir up 1 down -1)) + ; canvote protects against sockpuppet downvote of comments + (when (and (is dir 'up) (possible-sockpuppet user)) + (++ i!sockvotes)) + (metastory&adjust-rank i) + (unless (or (author user i) + (and (is ip i!ip) (~editor user)) + (is i!type 'pollopt)) + (++ (karma i!by) (case dir up 1 down -1)) + (save-prof i!by)) + (wipe (comment-cache* i!id))) + (if (admin user) (pushnew 'nokill i!keys)) + (push vote i!votes) + (save-item i) + (push (list (seconds) i!id i!by (sitename i!url) dir) + (uvar user votes)) + (= ((votes* user) i!id) vote) + (save-votes user) + (zap [firstn votewindow* _] (uvar user votes)) + (save-prof user) + (push (cons i!id vote) recent-votes*)))) + +; redefined later + +(def biased-voter (i vote) nil) + +; ugly to access vote fields by position number + +(def downvote-ratio (user (o sample 20)) + (ratio [is _.1.3 'down] + (keep [let by ((item (car _)) 'by) + (nor (is by user) (ignored by))] + (bestn sample (compare > car:cadr) (tablist (votes user)))))) + +(def just-downvoted (user victim (o n 3)) + (let prev (firstn n (recent-votes-by user)) + (and (is (len prev) n) + (all (fn ((id sec ip voter dir score)) + (and (author victim (item id)) (is dir 'down))) + prev)))) + +; Ugly to pluck out fourth element. Should read votes into a vote +; template. They're stored slightly differently in two diff places: +; in one with the voter in the car and the other without. + +(def recent-votes-by (user) + (keep [is _.3 user] recent-votes*)) + + +; Story Submission + +(newsop submit () + (if user + (submit-page user "" "" t) + (submit-login-warning "" "" t))) + +(def submit-login-warning ((o url) (o title) (o showtext) (o text)) + (login-page 'both "You have to be logged in to submit." + (fn (user ip) + (ensure-news-user user) + (newslog ip user 'submit-login) + (submit-page user url title showtext text)))) + +(def submit-page (user (o url) (o title) (o showtext) (o text "") (o msg)) + (minipage "Submit" + (pagemessage msg) + (urform user req + (process-story (get-user req) + (clean-url (arg req "u")) + (striptags (arg req "t")) + showtext + (and showtext (md-from-form (arg req "x") t)) + req!ip) + (tab + (row "title" (input "t" title 50)) + (if prefer-url* + (do (row "url" (input "u" url 50)) + (when showtext + (row "" "<b>or</b>") + (row "text" (textarea "x" 4 50 (only.pr text))))) + (do (row "text" (textarea "x" 4 50 (only.pr text))) + (row "" "<b>or</b>") + (row "url" (input "u" url 50)))) + (row "" (submit)) + (spacerow 20) + (row "" submit-instructions*))))) + +(= submit-instructions* + "Leave url blank to submit a question for discussion. If there is + no url, the text (if any) will appear at the top of the comments + page. If there is a url, the text will be ignored.") + +; For use by outside code like bookmarklet. +; http://news.domain.com/submitlink?u=http://foo.com&t=Foo +; Added a confirm step to avoid xss hacks. + +(newsop submitlink (u t) + (if user + (submit-page user u t) + (submit-login-warning u t))) + +(= title-limit* 80 + retry* "Please try again." + toolong* "Please make title < @title-limit* characters." + bothblank* "The url and text fields can't both be blank. Please + either supply a url, or if you're asking a question, + put it in the text field." + toofast* "You're submitting too fast. Please slow down. Thanks." + spammage* "Stop spamming us. You're wasting your time.") + +; Only for annoyingly high-volume spammers. For ordinary spammers it's +; enough to ban their sites and ip addresses. + +(disktable big-spamsites* (+ newsdir* "big-spamsites")) + +(def process-story (user url title showtext text ip) + (aif (and (~blank url) (live-story-w/url url)) + (do (vote-for user it) + (item-url it!id)) + (if (no user) + (flink [submit-login-warning url title showtext text]) + (no (and (or (blank url) (valid-url url)) + (~blank title))) + (flink [submit-page user url title showtext text retry*]) + (len> title title-limit*) + (flink [submit-page user url title showtext text toolong*]) + (and (blank url) (blank text)) + (flink [submit-page user url title showtext text bothblank*]) + (let site (sitename url) + (or (big-spamsites* site) (recent-spam site))) + (flink [msgpage user spammage*]) + (oversubmitting user ip 'story url) + (flink [msgpage user toofast*]) + (let s (create-story url (process-title title) text user ip) + (story-ban-test user s ip url) + (when (ignored user) (kill s 'ignored)) + (submit-item user s) + (maybe-ban-ip s) + "newest")))) + +(def submit-item (user i) + (push i!id (uvar user submitted)) + (save-prof user) + (vote-for user i)) + +(def recent-spam (site) + (and (caris (banned-sites* site) 'ignore) + (recent-items [is (sitename _!url) site] 720))) + +(def recent-items (test minutes) + (let cutoff (- (seconds) (* 60 minutes)) + (latest-items test [< _!time cutoff]))) + +; Turn this on when spam becomes a problem. + +(= enforce-oversubmit* nil) + +; New user can't submit more than 2 stories in a 2 hour period. +; Give overeager users the key toofast to make limit permanent. + +(def oversubmitting (user ip kind (o url)) + (and enforce-oversubmit* + (or (check-key user 'toofast) + (ignored user) + (< (user-age user) new-age-threshold*) + (< (karma user) new-karma-threshold*)) + (len> (recent-items [or (author user _) (is _!ip ip)] 180) + (if (is kind 'story) + (if (bad-user user) 0 1) + (if (bad-user user) 1 10))))) + +; Note that by deliberate tricks, someone could submit a story with a +; blank title. + +(diskvar scrubrules* (+ newsdir* "scrubrules")) + +(def process-title (s) + (let s2 (multisubst scrubrules* s) + (zap upcase (s2 0)) + s2)) + +(def live-story-w/url (url) + (aand (url->story* (canonical-url url)) (check (item it) live))) + +(def parse-site (url) + (rev (tokens (cadr (tokens url [in _ #\/ #\?])) #\.))) + +(defmemo sitename (url) + (and (valid-url url) + (let toks (parse-site (rem #\space url)) + (if (isa (saferead (car toks)) 'int) + (tostring (prall toks "" ".")) + (let (t1 t2 t3 . rest) toks + (if (and (~in t3 nil "www") + (or (mem t1 multi-tld-countries*) + (mem t2 long-domains*))) + (+ t3 "." t2 "." t1) + (and t2 (+ t2 "." t1)))))))) + +(= multi-tld-countries* '("uk" "jp" "au" "in" "ph" "tr" "za" "my" "nz" "br" + "mx" "th" "sg" "id" "pk" "eg" "il" "at" "pl")) + +(= long-domains* '("blogspot" "wordpress" "livejournal" "blogs" "typepad" + "weebly" "posterous" "blog-city" "supersized" "dreamhosters" + ; "sampasite" "multiply" "wetpaint" ; all spam, just ban + "eurekster" "blogsome" "edogo" "blog" "com")) + +(def create-story (url title text user ip) + (newslog ip user 'create url (list title)) + (let s (inst 'item 'type 'story 'id (new-item-id) + 'url url 'title title 'text text 'by user 'ip ip) + (save-item s) + (= (items* s!id) s) + (unless (blank url) (register-url s url)) + (push s stories*) + s)) + + +; Bans + +(def ignore (user subject cause) + (set (ignored subject)) + (save-prof subject) + (log-ignore user subject cause)) + +(diskvar ignore-log* (+ newsdir* "ignore-log")) + +(def log-ignore (user subject cause) + (todisk ignore-log* (cons (list subject user cause) ignore-log*))) + +; Kill means stuff with this substring gets killed. Ignore is stronger, +; means that user will be auto-ignored. Eventually this info should +; be stored on disk and not in the source code. + +(disktable banned-ips* (+ newsdir* "banned-ips")) ; was ips +(disktable banned-sites* (+ newsdir* "banned-sites")) ; was sites + +(diskvar comment-kill* (+ newsdir* "comment-kill")) +(diskvar comment-ignore* (+ newsdir* "comment-ignore")) + +(= comment-kill* nil ip-ban-threshold* 3) + +(def set-ip-ban (user ip yesno (o info)) + (= (banned-ips* ip) (and yesno (list user (seconds) info))) + (todisk banned-ips*)) + +(def set-site-ban (user site ban (o info)) + (= (banned-sites* site) (and ban (list ban user (seconds) info))) + (todisk banned-sites*)) + +; Kill submissions from banned ips, but don't auto-ignore users from +; them, because eventually ips will become legit again. + +; Note that ban tests are only applied when a link or comment is +; submitted, not each time it's edited. This will do for now. + +(def story-ban-test (user i ip url) + (site-ban-test user i url) + (ip-ban-test i ip) + (hook 'story-ban-test user i ip url)) + +(def site-ban-test (user i url) + (whenlet ban (banned-sites* (sitename url)) + (if (caris ban 'ignore) (ignore nil user 'site-ban)) + (kill i 'site-ban))) + +(def ip-ban-test (i ip) + (if (banned-ips* ip) (kill i 'banned-ip))) + +(def comment-ban-test (user i ip string kill-list ignore-list) + (when (some [posmatch _ string] ignore-list) + (ignore nil user 'comment-ban)) + (when (or (banned-ips* ip) (some [posmatch _ string] kill-list)) + (kill i 'comment-ban))) + +; An IP is banned when multiple ignored users have submitted over +; ban-threshold* (currently loaded) dead stories from it. + +; Can consider comments too if that later starts to be a problem, +; but the threshold may start to be higher because then you'd be +; dealing with trolls rather than spammers. + +(def maybe-ban-ip (s) + (when (and s!dead (ignored s!by)) + (let bads (loaded-items [and _!dead (astory _) (is _!ip s!ip)]) + (when (and (len> bads ip-ban-threshold*) + (some [and (ignored _!by) (isnt _!by s!by)] bads)) + (set-ip-ban nil s!ip t))))) + +(def killallby (user) + (map [kill _ 'all] (submissions user))) + +; Only called from repl. + +(def kill-whole-thread (c) + (kill c 'thread) + (map kill-whole-thread:item c!kids)) + + +; Polls + +; a way to add a karma threshold for voting in a poll +; or better still an arbitrary test fn, or at least pair of name/threshold. +; option to sort the elements of a poll when displaying +; exclusive field? (means only allow one vote per poll) + +(= poll-threshold* 20) + +(newsop newpoll () + (if (and user (> (karma user) poll-threshold*)) + (newpoll-page user) + (pr "Sorry, you need @poll-threshold* karma to create a poll."))) + +(def newpoll-page (user (o title "Poll: ") (o text "") (o opts "") (o msg)) + (minipage "New Poll" + (pagemessage msg) + (urform user req + (process-poll (get-user req) + (striptags (arg req "t")) + (md-from-form (arg req "x") t) + (striptags (arg req "o")) + req!ip) + (tab + (row "title" (input "t" title 50)) + (row "text" (textarea "x" 4 50 (only.pr text))) + (row "" "Use blank lines to separate choices:") + (row "choices" (textarea "o" 7 50 (only.pr opts))) + (row "" (submit)))))) + +(= fewopts* "A poll must have at least two options.") + +(def process-poll (user title text opts ip) + (if (or (blank title) (blank opts)) + (flink [newpoll-page user title text opts retry*]) + (len> title title-limit*) + (flink [newpoll-page user title text opts toolong*]) + (len< (paras opts) 2) + (flink [newpoll-page user title text opts fewopts*]) + (atlet p (create-poll (multisubst scrubrules* title) text opts user ip) + (ip-ban-test p ip) + (when (ignored user) (kill p 'ignored)) + (submit-item user p) + (maybe-ban-ip p) + "newest"))) + +(def create-poll (title text opts user ip) + (newslog ip user 'create-poll title) + (let p (inst 'item 'type 'poll 'id (new-item-id) + 'title title 'text text 'by user 'ip ip) + (= p!parts (map get!id (map [create-pollopt p nil nil _ user ip] + (paras opts)))) + (save-item p) + (= (items* p!id) p) + (push p stories*) + p)) + +(def create-pollopt (p url title text user ip) + (let o (inst 'item 'type 'pollopt 'id (new-item-id) + 'url url 'title title 'text text 'parent p!id + 'by user 'ip ip) + (save-item o) + (= (items* o!id) o) + o)) + +(def add-pollopt-page (p user) + (minipage "Add Poll Choice" + (urform user req + (do (add-pollopt user p (striptags (arg req "x")) req!ip) + (item-url p!id)) + (tab + (row "text" (textarea "x" 4 50)) + (row "" (submit)))))) + +(def add-pollopt (user p text ip) + (unless (blank text) + (atlet o (create-pollopt p nil nil text user ip) + (++ p!parts (list o!id)) + (save-item p)))) + +(def display-pollopts (p user whence) + (each o (visible user (map item p!parts)) + (display-pollopt nil o user whence) + (spacerow 7))) + +(def display-pollopt (n o user whence) + (tr (display-item-number n) + (tag (td valign 'top) + (votelinks o user whence)) + (tag (td class 'comment) + (tag (div style "margin-top:1px;margin-bottom:0px") + (if (~cansee user o) (pr (pseudo-text o)) + (~live o) (spanclass dead + (pr (if (~blank o!title) o!title o!text))) + (if (and (~blank o!title) (~blank o!url)) + (link o!title o!url) + (fontcolor black (pr o!text))))))) + (tr (if n (td)) + (td) + (tag (td class 'default) + (spanclass comhead + (itemscore o) + (editlink o user) + (killlink o user whence) + (deletelink o user whence) + (deadmark o user))))) + + +; Individual Item Page (= Comments Page of Stories) + +(defmemo item-url (id) (+ "item?id=" id)) + +(newsop item (id) + (let s (safe-item id) + (if (news-type s) + (do (if s!deleted (note-baditem user ip)) + (item-page user s)) + (do (note-baditem user ip) + (pr "No such item."))))) + +(= baditemreqs* (table) baditem-threshold* 1/100) + +; Something looking at a lot of deleted items is probably the bad sort +; of crawler. Throttle it for this server invocation. + +(def note-baditem (user ip) + (unless (admin user) + (++ (baditemreqs* ip 0)) + (with (r (requests/ip* ip) b (baditemreqs* ip)) + (when (and (> r 500) (> (/ b r) baditem-threshold*)) + (set (throttle-ips* ip)))))) + +; redefined later + +(def news-type (i) (and i (in i!type 'story 'comment 'poll 'pollopt))) + +(def item-page (user i) + (with (title (and (cansee user i) + (or i!title (aand i!text (ellipsize (striptags it))))) + here (item-url i!id)) + (longpage user (msec) nil nil title here + (tab (display-item nil i user here) + (display-item-text i user) + (when (apoll i) + (spacerow 10) + (tr (td) + (td (tab (display-pollopts i user here))))) + (when (and (cansee user i) (comments-active i)) + (spacerow 10) + (row "" (comment-form i user here)))) + (br2) + (when (and i!kids (commentable i)) + (tab (display-subcomments i user here)) + (br2))))) + +(def commentable (i) (in i!type 'story 'comment 'poll)) + +; By default the ability to comment on an item is turned off after +; 45 days, but this can be overriden with commentable key. + +(= commentable-threshold* (* 60 24 45)) + +(def comments-active (i) + (and (live&commentable i) + (live (superparent i)) + (or (< (item-age i) commentable-threshold*) + (mem 'commentable i!keys)))) + + +(= displayfn* (table)) + +(= (displayfn* 'story) (fn (n i user here inlist) + (display-story n i user here))) + +(= (displayfn* 'comment) (fn (n i user here inlist) + (display-comment n i user here nil 0 nil inlist))) + +(= (displayfn* 'poll) (displayfn* 'story)) + +(= (displayfn* 'pollopt) (fn (n i user here inlist) + (display-pollopt n i user here))) + +(def display-item (n i user here (o inlist)) + ((displayfn* (i 'type)) n i user here inlist)) + +(def superparent (i) + (aif i!parent (superparent:item it) i)) + +(def display-item-text (s user) + (when (and (cansee user s) + (in s!type 'story 'poll) + (blank s!url) + (~blank s!text)) + (spacerow 2) + (row "" s!text))) + + +; Edit Item + +(def edit-url (i) (+ "edit?id=" i!id)) + +(newsop edit (id) + (let i (safe-item id) + (if (and i + (cansee user i) + (editable-type i) + (or (news-type i) (admin user) (author user i))) + (edit-page user i) + (pr "No such item.")))) + +(def editable-type (i) (fieldfn* i!type)) + +(= fieldfn* (table)) + +(= (fieldfn* 'story) + (fn (user s) + (with (a (admin user) e (editor user) x (canedit user s)) + `((string1 title ,s!title t ,x) + (url url ,s!url t ,e) + (mdtext2 text ,s!text t ,x) + ,@(standard-item-fields s a e x))))) + +(= (fieldfn* 'comment) + (fn (user c) + (with (a (admin user) e (editor user) x (canedit user c)) + `((mdtext text ,c!text t ,x) + ,@(standard-item-fields c a e x))))) + +(= (fieldfn* 'poll) + (fn (user p) + (with (a (admin user) e (editor user) x (canedit user p)) + `((string1 title ,p!title t ,x) + (mdtext2 text ,p!text t ,x) + ,@(standard-item-fields p a e x))))) + +(= (fieldfn* 'pollopt) + (fn (user p) + (with (a (admin user) e (editor user) x (canedit user p)) + `((string title ,p!title t ,x) + (url url ,p!url t ,x) + (mdtext2 text ,p!text t ,x) + ,@(standard-item-fields p a e x))))) + +(def standard-item-fields (i a e x) + `((int votes ,(len i!votes) ,a nil) + (int score ,i!score t ,a) + (int sockvotes ,i!sockvotes ,a ,a) + (yesno dead ,i!dead ,e ,e) + (yesno deleted ,i!deleted ,a ,a) + (sexpr flags ,i!flags ,a nil) + (sexpr keys ,i!keys ,a ,a) + (string ip ,i!ip ,e nil))) + +; Should check valid-url etc here too. In fact make a fn that +; does everything that has to happen after submitting a story, +; and call it both there and here. + +(def edit-page (user i) + (let here (edit-url i) + (shortpage user nil nil "Edit" here + (tab (display-item nil i user here) + (display-item-text i user)) + (br2) + (vars-form user + ((fieldfn* i!type) user i) + (fn (name val) + (unless (ignore-edit user i name val) + (when (and (is name 'dead) val (no i!dead)) + (log-kill i user)) + (= (i name) val))) + (fn () (if (admin user) (pushnew 'locked i!keys)) + (save-item i) + (metastory&adjust-rank i) + (wipe (comment-cache* i!id)) + (edit-page user i))) + (hook 'edit user i)))) + +(def ignore-edit (user i name val) + (case name title (len> val title-limit*) + dead (and (mem 'nokill i!keys) (~admin user)))) + + +; Comment Submission + +(def comment-login-warning (parent whence (o text)) + (login-page 'both "You have to be logged in to comment." + (fn (u ip) + (ensure-news-user u) + (newslog ip u 'comment-login) + (addcomment-page parent u whence text)))) + +(def addcomment-page (parent user whence (o text) (o msg)) + (minipage "Add Comment" + (pagemessage msg) + (tab + (let here (flink [addcomment-page parent (get-user _) whence text msg]) + (display-item nil parent user here)) + (spacerow 10) + (row "" (comment-form parent user whence text))))) + +(= noob-comment-msg* nil) + +; Comment forms last for 30 min (- cache time) + +(def comment-form (parent user whence (o text)) + (tarform 1800 + (fn (req) + (when-umatch/r user req + (process-comment user parent (arg req "text") req!ip whence))) + (textarea "text" 6 60 + (aif text (prn (unmarkdown it)))) + (when (and noob-comment-msg* (noob user)) + (br2) + (spanclass subtext (pr noob-comment-msg*))) + (br2) + (submit (if (acomment parent) "reply" "add comment")))) + +(= comment-threshold* -20) + +; Have to remove #\returns because a form gives you back "a\r\nb" +; instead of just "a\nb". Maybe should just remove returns from +; the vals coming in from any form, e.g. in aform. + +(def process-comment (user parent text ip whence) + (if (no user) + (flink [comment-login-warning parent whence text]) + (empty text) + (flink [addcomment-page parent (get-user _) whence text retry*]) + (oversubmitting user ip 'comment) + (flink [msgpage user toofast*]) + (atlet c (create-comment parent (md-from-form text) user ip) + (comment-ban-test user c ip text comment-kill* comment-ignore*) + (if (bad-user user) (kill c 'ignored/karma)) + (submit-item user c) + whence))) + +(def bad-user (u) + (or (ignored u) (< (karma u) comment-threshold*))) + +(def create-comment (parent text user ip) + (newslog ip user 'comment (parent 'id)) + (let c (inst 'item 'type 'comment 'id (new-item-id) + 'text text 'parent parent!id 'by user 'ip ip) + (save-item c) + (= (items* c!id) c) + (push c!id parent!kids) + (save-item parent) + (push c comments*) + c)) + + +; Comment Display + +(def display-comment-tree (c user whence (o indent 0) (o initialpar)) + (when (cansee-descendant user c) + (display-1comment c user whence indent initialpar) + (display-subcomments c user whence (+ indent 1)))) + +(def display-1comment (c user whence indent showpar) + (row (tab (display-comment nil c user whence t indent showpar showpar)))) + +(def display-subcomments (c user whence (o indent 0)) + (each k (sort (compare > frontpage-rank:item) c!kids) + (display-comment-tree (item k) user whence indent))) + +(def display-comment (n c user whence (o astree) (o indent 0) + (o showpar) (o showon)) + (tr (display-item-number n) + (when astree (td (hspace (* indent 40)))) + (tag (td valign 'top) (votelinks c user whence t)) + (display-comment-body c user whence astree indent showpar showon))) + +; Comment caching doesn't make generation of comments significantly +; faster, but may speed up everything else by generating less garbage. + +; It might solve the same problem more generally to make html code +; more efficient. + +(= comment-cache* (table) comment-cache-timeout* (table) cc-window* 10000) + +(= comments-printed* 0 cc-hits* 0) + +(= comment-caching* t) + +; Cache comments generated for nil user that are over an hour old. +; Only try to cache most recent 10k items. But this window moves, +; so if server is running a long time could have more than that in +; cache. Probably should actively gc expired cache entries. + +(def display-comment-body (c user whence astree indent showpar showon) + (++ comments-printed*) + (if (and comment-caching* + astree (no showpar) (no showon) + (live c) + (nor (admin user) (editor user) (author user c)) + (< (- maxid* c!id) cc-window*) + (> (- (seconds) c!time) 60)) ; was 3600 + (pr (cached-comment-body c user whence indent)) + (gen-comment-body c user whence astree indent showpar showon))) + +(def cached-comment-body (c user whence indent) + (or (and (> (or (comment-cache-timeout* c!id) 0) (seconds)) + (awhen (comment-cache* c!id) + (++ cc-hits*) + it)) + (= (comment-cache-timeout* c!id) + (cc-timeout c!time) + (comment-cache* c!id) + (tostring (gen-comment-body c user whence t indent nil nil))))) + +; Cache for the remainder of the current minute, hour, or day. + +(def cc-timeout (t0) + (let age (- (seconds) t0) + (+ t0 (if (< age 3600) + (* (+ (trunc (/ age 60)) 1) 60) + (< age 86400) + (* (+ (trunc (/ age 3600)) 1) 3600) + (* (+ (trunc (/ age 86400)) 1) 86400))))) + +(def gen-comment-body (c user whence astree indent showpar showon) + (tag (td class 'default) + (let parent (and (or (no astree) showpar) (c 'parent)) + (tag (div style "margin-top:2px; margin-bottom:-10px; ") + (spanclass comhead + (itemline c user) + (permalink c user) + (when parent + (when (cansee user c) (pr bar*)) + (link "parent" (item-url ((item parent) 'id)))) + (editlink c user) + (killlink c user whence) + (blastlink c user whence) + (deletelink c user whence) + ; a hack to check whence but otherwise need an arg just for this + (unless (or astree (is whence "newcomments")) + (flaglink c user whence)) + (deadmark c user) + (when showon + (pr " | on: ") + (let s (superparent c) + (link (ellipsize s!title 50) (item-url s!id)))))) + (when (or parent (cansee user c)) + (br)) + (spanclass comment + (if (~cansee user c) (pr (pseudo-text c)) + (nor (live c) (author user c)) (spanclass dead (pr c!text)) + (fontcolor (comment-color c) + (pr c!text)))) + (when (and astree (cansee user c) (live c)) + (para) + (tag (font size 1) + (if (and (~mem 'neutered c!keys) + (replyable c indent) + (comments-active c)) + (underline (replylink c whence)) + (fontcolor sand (pr "-----")))))))) + +; For really deeply nested comments, caching could add another reply +; delay, but that's ok. + +; People could beat this by going to the link url or manually entering +; the reply url, but deal with that if they do. + +(= reply-decay* 1.8) ; delays: (0 0 1 3 7 12 18 25 33 42 52 63) + +(def replyable (c indent) + (or (< indent 2) + (> (item-age c) (expt (- indent 1) reply-decay*)))) + +(def replylink (i whence (o title 'reply)) + (link title (+ "reply?id=" i!id "&whence=" (urlencode whence)))) + +(newsop reply (id whence) + (with (i (safe-item id) + whence (or (only.urldecode whence) "news")) + (if (only.comments-active i) + (if user + (addcomment-page i user whence) + (login-page 'both "You have to be logged in to comment." + (fn (u ip) + (ensure-news-user u) + (newslog ip u 'comment-login) + (addcomment-page i u whence)))) + (pr "No such item.")))) + +(def comment-color (c) + (if (> c!score 0) black (grayrange c!score))) + +(defmemo grayrange (s) + (gray (min 230 (round (expt (* (+ (abs s) 2) 900) .6))))) + + +; Threads + +(def threads-url (user) (+ "threads?id=" user)) + +(newsop threads (id) + (if id + (threads-page user id) + (pr "No user specified."))) + +(def threads-page (user subject) + (if (profile subject) + (withs (title (+ subject "'s comments") + label (if (is user subject) "threads" title) + here (threads-url subject)) + (longpage user (msec) nil label title here + (awhen (keep [and (cansee user _) (~subcomment _)] + (comments subject maxend*)) + (display-threads user it label title here)))) + (prn "No such user."))) + +(def display-threads (user comments label title whence + (o start 0) (o end threads-perpage*)) + (tab + (each c (cut comments start end) + (display-comment-tree c user whence 0 t)) + (when end + (let newend (+ end threads-perpage*) + (when (and (<= newend maxend*) (< end (len comments))) + (spacerow 10) + (row (tab (tr (td (hspace 0)) + (td (hspace votewid*)) + (tag (td class 'title) + (morelink display-threads + comments label title end newend)))))))))) + +(def submissions (user (o limit)) + (map item (firstn limit (uvar user submitted)))) + +(def comments (user (o limit)) + (map item (retrieve limit acomment:item (uvar user submitted)))) + +(def subcomment (c) + (some [and (acomment _) (is _!by c!by) (no _!deleted)] + (ancestors c))) + +(def ancestors (i) + (accum a (trav i!parent a:item self:!parent:item))) + + +; Submitted + +(def submitted-url (user) (+ "submitted?id=" user)) + +(newsop submitted (id) + (if id + (submitted-page user id) + (pr "No user specified."))) + +(def submitted-page (user subject) + (if (profile subject) + (with (label (+ subject "'s submissions") + here (submitted-url subject)) + (longpage user (msec) nil label label here + (if (or (no (ignored subject)) + (is user subject) + (seesdead user)) + (aif (keep [and (metastory _) (cansee user _)] + (submissions subject)) + (display-items user it label label here 0 perpage* t))))) + (pr "No such user."))) + + +; RSS + +(newsop rss () (rsspage nil)) + +(newscache rsspage user 90 + (rss-stories (retrieve perpage* live ranked-stories*))) + +(def rss-stories (stories) + (tag (rss version "2.0") + (tag channel + (tag title (pr this-site*)) + (tag link (pr site-url*)) + (tag description (pr site-desc*)) + (each s stories + (tag item + (let comurl (+ site-url* (item-url s!id)) + (tag title (pr (eschtml s!title))) + (tag link (pr (if (blank s!url) comurl (eschtml s!url)))) + (tag comments (pr comurl)) + (tag description + (cdata (link "Comments" comurl))))))))) + + +; User Stats + +(newsop leaders () (leaderspage user)) + +(= nleaders* 20) + +(newscache leaderspage user 1000 + (longpage user (msec) nil "leaders" "Leaders" "leaders" + (sptab + (let i 0 + (each u (firstn nleaders* (leading-users)) + (tr (tdr:pr (++ i) ".") + (td (userlink user u nil)) + (tdr:pr (karma u)) + (when (admin user) + (tdr:prt (only.num (uvar u avg) 2 t t)))) + (if (is i 10) (spacerow 30))))))) + +(= leader-threshold* 1) ; redefined later + +(def leading-users () + (sort (compare > [karma _]) + (users [and (> (karma _) leader-threshold*) (~admin _)]))) + +(adop editors () + (tab (each u (users [is (uvar _ auth) 1]) + (row (userlink user u))))) + + +(= update-avg-threshold* 0) ; redefined later + +(defbg update-avg 45 + (unless (or (empty profs*) (no stories*)) + (update-avg (rand-user [and (only.> (car (uvar _ submitted)) + (- maxid* initload*)) + (len> (uvar _ submitted) + update-avg-threshold*)])))) + +(def update-avg (user) + (= (uvar user avg) (comment-score user)) + (save-prof user)) + +(def rand-user ((o test idfn)) + (evtil (rand-key profs*) test)) + +; Ignore the most recent 5 comments since they may still be gaining votes. +; Also ignore the highest-scoring comment, since possibly a fluff outlier. + +(def comment-score (user) + (aif (check (nthcdr 5 (comments user 50)) [len> _ 10]) + (avg (cdr (sort > (map !score (rem !deleted it))))) + nil)) + + +; Comment Analysis + +; Instead of a separate active op, should probably display this info +; implicitly by e.g. changing color of commentlink or by showing the +; no of comments since that user last looked. + +(newsop active () (active-page user)) + +(newscache active-page user 600 + (listpage user (msec) (actives user) "active" "Active Threads")) + +(def actives (user (o n maxend*) (o consider 2000)) + (visible user (rank-stories n consider (memo active-rank)))) + +(= active-threshold* 1500) + +(def active-rank (s) + (sum [max 0 (- active-threshold* (item-age _))] + (cdr (family s)))) + +(def family (i) (cons i (mappend family:item i!kids))) + + +(newsop newcomments () (newcomments-page user)) + +(newscache newcomments-page user 60 + (listpage user (msec) (visible user (firstn maxend* comments*)) + "comments" "New Comments" "newcomments" nil)) + + +; Doc + +(defop formatdoc req + (msgpage (get-user req) formatdoc* "Formatting Options")) + +(= formatdoc-url* "formatdoc") + +(= formatdoc* +"Blank lines separate paragraphs. +<p> Text after a blank line that is indented by two or more spaces is +reproduced verbatim. (This is intended for code.) +<p> Text surrounded by asterisks is italicized, if the character after the +first asterisk isn't whitespace. +<p> Urls become links, except in the text field of a submission.<br><br>") + + +; Noprocrast + +(def check-procrast (user) + (or (no user) + (no (uvar user noprocrast)) + (let now (seconds) + (unless (uvar user firstview) + (reset-procrast user)) + (or (when (< (/ (- now (uvar user firstview)) 60) + (uvar user maxvisit)) + (= (uvar user lastview) now) + (save-prof user) + t) + (when (> (/ (- now (uvar user lastview)) 60) + (uvar user minaway)) + (reset-procrast user) + t))))) + +(def reset-procrast (user) + (= (uvar user lastview) (= (uvar user firstview) (seconds))) + (save-prof user)) + +(def procrast-msg (user whence) + (let m (+ 1 (trunc (- (uvar user minaway) + (minutes-since (uvar user lastview))))) + (pr "<b>Get back to work!</b>") + (para "Sorry, you can't see this page. Based on the anti-procrastination + parameters you set in your profile, you'll be able to use the site + again in " (plural m "minute") ".") + (para "(If you got this message after submitting something, don't worry, + the submission was processed.)") + (para "To change your anti-procrastination settings, go to your profile + by clicking on your username. If <tt>noprocrast</tt> is set to + <tt>yes</tt>, you'll be limited to sessions of <tt>maxvisit</tt> + minutes, with <tt>minaway</tt> minutes between them.") + (para) + (w/rlink whence (underline (pr "retry"))) + ; (hspace 20) + ; (w/rlink (do (reset-procrast user) whence) (underline (pr "override"))) + (br2))) + + +; Reset PW + +(defopg resetpw req (resetpw-page (get-user req))) + +(def resetpw-page (user (o msg)) + (minipage "Reset Password" + (if msg + (pr msg) + (blank (uvar user email)) + (do (pr "Before you do this, please add your email address to your ") + (underlink "profile" (user-url user)) + (pr ". Otherwise you could lose your account if you mistype + your new password."))) + (br2) + (uform user req (try-resetpw user (arg req "p")) + (single-input "New password: " 'p 20 "reset" t)))) + +(def try-resetpw (user newpw) + (if (len< newpw 4) + (resetpw-page user "Passwords should be a least 4 characters long. + Please choose another.") + (do (set-pw user newpw) + (newspage user)))) + + +; Scrubrules + +(defopa scrubrules req + (scrub-page (get-user req) scrubrules*)) + +; If have other global alists, generalize an alist edit page. +; Or better still generalize vars-form. + +(def scrub-page (user rules (o msg nil)) + (minipage "Scrubrules" + (when msg (pr msg) (br2)) + (uform user req + (with (froms (lines (arg req "from")) + tos (lines (arg req "to"))) + (if (is (len froms) (len tos)) + (do (todisk scrubrules* (map list froms tos)) + (scrub-page user scrubrules* "Changes saved.")) + (scrub-page user rules "To and from should be same length."))) + (pr "From: ") + (tag (textarea name 'from + cols (apply max 20 (map len (map car rules))) + rows (+ (len rules) 3)) + (apply pr #\newline (intersperse #\newline (map car rules)))) + (pr " To: ") + (tag (textarea name 'to + cols (apply max 20 (map len (map cadr rules))) + rows (+ (len rules) 3)) + (apply pr #\newline (intersperse #\newline (map cadr rules)))) + (br2) + (submit "update")))) + + +; Abuse Analysis + +(adop badsites () + (sptab + (row "Dead" "Days" "Site" "O" "K" "I" "Users") + (each (site deads) (with (banned (banned-site-items) + pairs (killedsites)) + (+ pairs (map [list _ (banned _)] + (rem (fn (d) + (some [caris _ d] pairs)) + (keys banned-sites*))))) + (let ban (car (banned-sites* site)) + (tr (tdr (when deads + (onlink (len deads) + (listpage user (msec) deads + nil (+ "killed at " site) "badsites")))) + (tdr (when deads (pr (round (days-since ((car deads) 'time)))))) + (td site) + (td (w/rlink (do (set-site-ban user site nil) "badsites") + (fontcolor (if ban gray.220 black) (pr "x")))) + (td (w/rlink (do (set-site-ban user site 'kill) "badsites") + (fontcolor (case ban kill darkred gray.220) (pr "x")))) + (td (w/rlink (do (set-site-ban user site 'ignore) "badsites") + (fontcolor (case ban ignore darkred gray.220) (pr "x")))) + (td (each u (dedup (map !by deads)) + (userlink user u nil) + (pr " ")))))))) + +(defcache killedsites 300 + (let bads (table [each-loaded-item i + (awhen (and i!dead (sitename i!url)) + (push i (_ it)))]) + (with (acc nil deadcount (table)) + (each (site items) bads + (let n (len items) + (when (> n 2) + (= (deadcount site) n) + (insort (compare > deadcount:car) + (list site (rev items)) + acc)))) + acc))) + +(defcache banned-site-items 300 + (table [each-loaded-item i + (awhen (and i!dead (check (sitename i!url) banned-sites*)) + (push i (_ it)))])) + +; Would be nice to auto unban ips whose most recent submission is > n +; days old, but hard to do because of lazy loading. Would have to keep +; a table of most recent submission per ip, and only enforce bannnedness +; if < n days ago. + +(adop badips () + (withs ((bads goods) (badips) + (subs ips) (sorted-badips bads goods)) + (sptab + (row "IP" "Days" "Dead" "Live" "Users") + (each ip ips + (tr (td (let banned (banned-ips* ip) + (w/rlink (do (set-ip-ban user ip (no banned)) + "badips") + (fontcolor (if banned darkred) (pr ip))))) + (tdr (when (or (goods ip) (bads ip)) + (pr (round (days-since + (max (aif (car (goods ip)) it!time 0) + (aif (car (bads ip)) it!time 0))))))) + (tdr (onlink (len (bads ip)) + (listpage user (msec) (bads ip) + nil (+ "dead from " ip) "badips"))) + (tdr (onlink (len (goods ip)) + (listpage user (msec) (goods ip) + nil (+ "live from " ip) "badips"))) + (td (each u (subs ip) + (userlink user u nil) + (pr " ")))))))) + +(defcache badips 300 + (with (bads (table) goods (table)) + (each-loaded-item s + (if (and s!dead (commentable s)) + (push s (bads s!ip)) + (push s (goods s!ip)))) + (each (k v) bads (zap rev (bads k))) + (each (k v) goods (zap rev (goods k))) + (list bads goods))) + +(def sorted-badips (bads goods) + (withs (ips (let ips (rem [len< (bads _) 2] (keys bads)) + (+ ips (rem [mem _ ips] (keys banned-ips*)))) + subs (table + [each ip ips + (= (_ ip) (dedup (map !by (+ (bads ip) (goods ip)))))])) + (list subs + (sort (compare > (memo [badness (subs _) (bads _) (goods _)])) + ips)))) + +(def badness (subs bads goods) + (* (/ (len bads) + (max .9 (expt (len goods) 2)) + (expt (+ (days-since (aif (car bads) it!time 0)) + 1) + 2)) + (if (len> subs 1) 20 1))) + + +(edop flagged () + (display-selected-items user [retrieve maxend* flagged _] "flagged")) + +(def flagged (i) + (and (live i) + (~mem 'nokill i!keys) + (len> i!flags many-flags*))) + + +(edop killed () + (display-selected-items user [retrieve maxend* !dead _] "killed")) + +(def display-selected-items (user f whence) + (display-items user (f stories*) nil nil whence) + (vspace 35) + (color-stripe textgray) + (vspace 35) + (display-items user (f comments*) nil nil whence)) + + +; Rather useless thus; should add more data. + +(adop badguys () + (tab (each u (sort (compare > [uvar _ created]) + (users [ignored _])) + (row (userlink user u nil))))) + +(adop badlogins () (logins-page bad-logins*)) + +(adop goodlogins () (logins-page good-logins*)) + +(def logins-page (source) + (sptab (each (time ip user) (firstn 100 (rev (qlist source))) + (row time ip user)))) + + +; Stats + +(adop optimes () + (sptab + (tr (td "op") (tdr "avg") (tdr "med") (tdr "req") (tdr "total")) + (spacerow 10) + (each name (sort < newsop-names*) + (tr (td name) + (let ms (only.avg (qlist (optimes* name))) + (tdr:prt (only.round ms)) + (tdr:prt (only.med (qlist (optimes* name)))) + (let n (opcounts* name) + (tdr:prt n) + (tdr:prt (and n (round (/ (* n ms) 1000)))))))))) + +(defop topcolors req + (minipage "Custom Colors" + (tab + (each c (dedup (map downcase (trues [uvar _ topcolor] (users)))) + (tr (td c) (tdcolor (hex>color c) (hspace 30))))))) + + diff --git a/pprint.arc b/pprint.arc new file mode 100644 index 0000000..e4d3c4e --- /dev/null +++ b/pprint.arc @@ -0,0 +1,80 @@ +; Pretty-Printing. Spun off 4 Aug 06. + +; todo: indentation of long ifs; quasiquote, unquote, unquote-splicing + +(= bodops* (fill-table (table) + '(let 2 with 1 while 1 def 2 fn 1 rfn 2 afn 1 + when 1 unless 1 after 1 whilet 2 for 3 each 2 whenlet 2 awhen 1 + whitepage 0 tag 1 form 1 aform 1 aformh 1 w/link 1 textarea 3 + ))) + +(= oneline* 35) ; print exprs less than this long on one line + +; If returns nil, can assume it didn't have to break expr. + +(def ppr (expr (o col 0) (o noindent nil)) + (if (or (atom expr) (dotted expr)) + (do (unless noindent (sp col)) + (write expr) + nil) + (is (car expr) 'quote) + (do (unless noindent (sp col)) + (pr "'") + (ppr (cadr expr) (+ col 1) t)) + (bodops* (car expr)) + (do (unless noindent (sp col)) + (let whole (tostring (write expr)) + (if (< (len whole) oneline*) + (do (pr whole) nil) + (ppr-progn expr col noindent)))) + (do (unless noindent (sp col)) + (let whole (tostring (write expr)) + (if (< (len whole) oneline*) + (do (pr whole) nil) + (ppr-call expr col noindent)))))) + +(def ppr-progn (expr col noindent) + (lpar) + (let n (bodops* (car expr)) + (let str (tostring (write-spaced (firstn n expr))) + (unless (is n 0) (pr str) (sp)) + (ppr (expr n) (+ col (len str) 2) t)) + (map (fn (e) (prn) (ppr e (+ col 2))) + (nthcdr (+ n 1) expr))) + (rpar) + t) + +(def ppr-call (expr col noindent) + (lpar) + (let carstr (tostring (write (car expr))) + (pr carstr) + (if (cdr expr) + (do (sp) + (let broke (ppr (cadr expr) (+ col (len carstr) 2) t) + (pprest (cddr expr) + (+ col (len carstr) 2) + (no broke))) + t) + (do (rpar) t)))) + +(def pprest (exprs col (o oneline t)) + (if (and oneline + (all (fn (e) + (or (atom e) (and (is (car e) 'quote) (atom (cadr e))))) + exprs)) + (do (map (fn (e) (pr " ") (write e)) + exprs) + (rpar)) + (do (when exprs + (each e exprs (prn) (ppr e col))) + (rpar)))) + +(def write-spaced (xs) + (when xs + (write (car xs)) + (each x (cdr xs) (pr " ") (write x)))) + +(def sp ((o n 1)) (repeat n (pr " "))) +(def lpar () (pr "(")) +(def rpar () (pr ")")) + diff --git a/prompt.arc b/prompt.arc new file mode 100644 index 0000000..af34e53 --- /dev/null +++ b/prompt.arc @@ -0,0 +1,119 @@ +; 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))))) + @@ -0,0 +1,573 @@ +; HTTP Server. + +; To improve performance with static files, set static-max-age*. + +(= arcdir* "arc/" logdir* "arc/logs/" staticdir* "static/") + +(= quitsrv* nil breaksrv* nil) + +(def serve ((o port 8080)) + (wipe quitsrv*) + (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) + (until quitsrv* + (handle-request s breaksrv*))) + (prn "quit server")) + +(def serve1 ((o port 8080)) + (w/socket s port (handle-request s t))) + +(def ensure-srvdirs () + (map ensure-dir (list arcdir* logdir* staticdir*))) + +(= srv-noisy* nil) + +; http requests currently capped at 2 meg by socket-accept + +; should threads process requests one at a time? no, then +; a browser that's slow consuming the data could hang the +; whole server. + +; wait for a connection from a browser and start a thread +; to handle it. also arrange to kill that thread if it +; has not completed in threadlife* seconds. + +(= threadlife* 30 requests* 0 requests/ip* (table) + throttle-ips* (table) ignore-ips* (table) spurned* (table)) + +(def handle-request (s breaksrv) + (if breaksrv + (handle-request-1 s) + (errsafe (handle-request-1 s)))) + +(def handle-request-1 (s) + (let (i o ip) (socket-accept s) + (if (and (or (ignore-ips* ip) (abusive-ip ip)) + (++ (spurned* ip 0))) + (force-close i o) + (do (++ requests*) + (++ (requests/ip* ip 0)) + (with (th1 nil th2 nil) + (= th1 (thread + (after (handle-request-thread i o ip) + (close i o) + (kill-thread th2)))) + (= th2 (thread + (sleep threadlife*) + (unless (dead th1) + (prn "srv thread took too long for " ip)) + (break-thread th1) + (force-close i o)))))))) + +; Returns true if ip has made req-limit* requests in less than +; req-window* seconds. If an ip is throttled, only 1 request is +; allowed per req-window* seconds. If an ip makes req-limit* +; requests in less than dos-window* seconds, it is a treated as a DoS +; attack and put in ignore-ips* (for this server invocation). + +; To adjust this while running, adjust the req-window* time, not +; req-limit*, because algorithm doesn't enforce decreases in the latter. + +(= req-times* (table) req-limit* 30 req-window* 10 dos-window* 2) + +(def abusive-ip (ip) + (and (only.> (requests/ip* ip) 250) + (let now (seconds) + (do1 (if (req-times* ip) + (and (>= (qlen (req-times* ip)) + (if (throttle-ips* ip) 1 req-limit*)) + (let dt (- now (deq (req-times* ip))) + (if (< dt dos-window*) (set (ignore-ips* ip))) + (< dt req-window*))) + (do (= (req-times* ip) (queue)) + nil)) + (enq now (req-times* ip)))))) + +(def handle-request-thread (i o ip) + (with (nls 0 lines nil line nil responded nil t0 (msec)) + (after + (whilet c (unless responded (readc i)) + (if srv-noisy* (pr c)) + (if (is c #\newline) + (if (is (++ nls) 2) + (let (type op args n cooks) (parseheader (rev lines)) + (let t1 (msec) + (case type + get (respond o op args cooks ip) + post (handle-post i o op args n cooks ip) + (respond-err o "Unknown request: " (car lines))) + (log-request type op args cooks ip t0 t1) + (set responded))) + (do (push (string (rev line)) lines) + (wipe line))) + (unless (is c #\return) + (push c line) + (= nls 0)))) + (close i o))) + (harvest-fnids)) + +(def log-request (type op args cooks ip t0 t1) + (with (parsetime (- t1 t0) respondtime (- (msec) t1)) + (srvlog 'srv ip + parsetime + respondtime + (if (> (+ parsetime respondtime) 1000) "***" "") + type + op + (let arg1 (car args) + (if (caris arg1 "fnid") "" arg1)) + cooks))) + +; Could ignore return chars (which come from textarea fields) here by +; (unless (is c #\return) (push c line)) + +(def handle-post (i o op args n cooks ip) + (if srv-noisy* (pr "Post Contents: ")) + (if (no n) + (respond-err o "Post request without Content-Length.") + (let line nil + (whilet c (and (> n 0) (readc i)) + (if srv-noisy* (pr c)) + (-- n) + (push c line)) + (if srv-noisy* (pr "\n\n")) + (respond o op (+ (parseargs (string (rev line))) args) cooks ip)))) + +(= header* "HTTP/1.1 200 OK +Content-Type: text/html; charset=utf-8 +Connection: close") + +(= type-header* (table)) + +(def gen-type-header (ctype) + (+ "HTTP/1.0 200 OK +Content-Type: " + ctype + " +Connection: close")) + +(map (fn ((k v)) (= (type-header* k) (gen-type-header v))) + '((gif "image/gif") + (jpg "image/jpeg") + (png "image/png") + (text/html "text/html; charset=utf-8"))) + +(= rdheader* "HTTP/1.0 302 Moved") + +(= srvops* (table) redirector* (table) optimes* (table) opcounts* (table)) + +(def save-optime (name elapsed) + ; this is the place to put a/b testing + ; toggle a flag and push elapsed into one of two lists + (++ (opcounts* name 0)) + (unless (optimes* name) (= (optimes* name) (queue))) + (enq-limit elapsed (optimes* name) 1000)) + +; For ops that want to add their own headers. They must thus remember +; to prn a blank line before anything meant to be part of the page. + +(mac defop-raw (name parms . body) + (w/uniq t1 + `(= (srvops* ',name) + (fn ,parms + (let ,t1 (msec) + (do1 (do ,@body) + (save-optime ',name (- (msec) ,t1)))))))) + +(mac defopr-raw (name parms . body) + `(= (redirector* ',name) t + (srvops* ',name) (fn ,parms ,@body))) + +(mac defop (name parm . body) + (w/uniq gs + `(do (wipe (redirector* ',name)) + (defop-raw ,name (,gs ,parm) + (w/stdout ,gs (prn) ,@body))))) + +; Defines op as a redirector. Its retval is new location. + +(mac defopr (name parm . body) + (w/uniq gs + `(do (set (redirector* ',name)) + (defop-raw ,name (,gs ,parm) + ,@body)))) + +;(mac testop (name . args) `((srvops* ',name) ,@args)) + +(deftem request + args nil + cooks nil + ip nil) + +(= unknown-msg* "Unknown." max-age* (table) static-max-age* nil) + +(def respond (str op args cooks ip) + (w/stdout str + (iflet f (srvops* op) + (let req (inst 'request 'args args 'cooks cooks 'ip ip) + (if (redirector* op) + (do (prn rdheader*) + (prn "Location: " (f str req)) + (prn)) + (do (prn header*) + (awhen (max-age* op) + (prn "Cache-Control: max-age=" it)) + (f str req)))) + (let filetype (static-filetype op) + (aif (and filetype (file-exists (string staticdir* op))) + (do (prn (type-header* filetype)) + (awhen static-max-age* + (prn "Cache-Control: max-age=" it)) + (prn) + (w/infile i it + (whilet b (readb i) + (writeb b str)))) + (respond-err str unknown-msg*)))))) + +(def static-filetype (sym) + (let fname (coerce sym 'string) + (and (~find #\/ fname) + (case (downcase (last (check (tokens fname #\.) ~single))) + "gif" 'gif + "jpg" 'jpg + "jpeg" 'jpg + "png" 'png + "css" 'text/html + "txt" 'text/html + "htm" 'text/html + "html" 'text/html + "arc" 'text/html + )))) + +(def respond-err (str msg . args) + (w/stdout str + (prn header*) + (prn) + (apply pr msg args))) + +(def parseheader (lines) + (let (type op args) (parseurl (car lines)) + (list type + op + args + (and (is type 'post) + (some (fn (s) + (and (begins s "Content-Length:") + (errsafe:coerce (cadr (tokens s)) 'int))) + (cdr lines))) + (some (fn (s) + (and (begins s "Cookie:") + (parsecookies s))) + (cdr lines))))) + +; (parseurl "GET /p1?foo=bar&ug etc") -> (get p1 (("foo" "bar") ("ug"))) + +(def parseurl (s) + (let (type url) (tokens s) + (let (base args) (tokens url #\?) + (list (sym (downcase type)) + (sym (cut base 1)) + (if args + (parseargs args) + nil))))) + +; I don't urldecode field names or anything in cookies; correct? + +(def parseargs (s) + (map (fn ((k v)) (list k (urldecode v))) + (map [tokens _ #\=] (tokens s #\&)))) + +(def parsecookies (s) + (map [tokens _ #\=] + (cdr (tokens s [or (whitec _) (is _ #\;)])))) + +(def arg (req key) (alref req!args key)) + +; *** Warning: does not currently urlencode args, so if need to do +; that replace v with (urlencode v). + +(def reassemble-args (req) + (aif req!args + (apply string "?" (intersperse '& + (map (fn ((k v)) + (string k '= v)) + it))) + "")) + +(= fns* (table) fnids* nil timed-fnids* nil) + +; count on huge (expt 64 10) size of fnid space to avoid clashes + +(def new-fnid () + (check (sym (rand-string 10)) ~fns* (new-fnid))) + +(def fnid (f) + (atlet key (new-fnid) + (= (fns* key) f) + (push key fnids*) + key)) + +(def timed-fnid (lasts f) + (atlet key (new-fnid) + (= (fns* key) f) + (push (list key (seconds) lasts) timed-fnids*) + key)) + +; Within f, it will be bound to the fn's own fnid. Remember that this is +; so low-level that need to generate the newline to separate from the headers +; within the body of f. + +(mac afnid (f) + `(atlet it (new-fnid) + (= (fns* it) ,f) + (push it fnids*) + it)) + +;(defop test-afnid req +; (tag (a href (url-for (afnid (fn (req) (prn) (pr "my fnid is " it))))) +; (pr "click here"))) + +; To be more sophisticated, instead of killing fnids, could first +; replace them with fns that tell the server it's harvesting too +; aggressively if they start to get called. But the right thing to +; do is estimate what the max no of fnids can be and set the harvest +; limit there-- beyond that the only solution is to buy more memory. + +(def harvest-fnids ((o n 50000)) ; was 20000 + (when (len> fns* n) + (pull (fn ((id created lasts)) + (when (> (since created) lasts) + (wipe (fns* id)) + t)) + timed-fnids*) + (atlet nharvest (trunc (/ n 10)) + (let (kill keep) (split (rev fnids*) nharvest) + (= fnids* (rev keep)) + (each id kill + (wipe (fns* id))))))) + +(= fnurl* "/x" rfnurl* "/r" rfnurl2* "/y" jfnurl* "/a") + +(= dead-msg* "\nUnknown or expired link.") + +(defop-raw x (str req) + (w/stdout str + (aif (fns* (sym (arg req "fnid"))) + (it req) + (pr dead-msg*)))) + +(defopr-raw y (str req) + (aif (fns* (sym (arg req "fnid"))) + (w/stdout str (it req)) + "deadlink")) + +; For asynchronous calls; discards the page. Would be better to tell +; the fn not to generate it. + +(defop-raw a (str req) + (aif (fns* (sym (arg req "fnid"))) + (tostring (it req)))) + +(defopr r req + (aif (fns* (sym (arg req "fnid"))) + (it req) + "deadlink")) + +(defop deadlink req + (pr dead-msg*)) + +(def url-for (fnid) + (string fnurl* "?fnid=" fnid)) + +(def flink (f) + (string fnurl* "?fnid=" (fnid (fn (req) (prn) (f req))))) + +(def rflink (f) + (string rfnurl* "?fnid=" (fnid f))) + +; Since it's just an expr, gensym a parm for (ignored) args. + +(mac w/link (expr . body) + `(tag (a href (flink (fn (,(uniq)) ,expr))) + ,@body)) + +(mac w/rlink (expr . body) + `(tag (a href (rflink (fn (,(uniq)) ,expr))) + ,@body)) + +(mac onlink (text . body) + `(w/link (do ,@body) (pr ,text))) + +(mac onrlink (text . body) + `(w/rlink (do ,@body) (pr ,text))) + +; bad to have both flink and linkf; rename flink something like fnid-link + +(mac linkf (text parms . body) + `(tag (a href (flink (fn ,parms ,@body))) (pr ,text))) + +(mac rlinkf (text parms . body) + `(tag (a href (rflink (fn ,parms ,@body))) (pr ,text))) + +;(defop top req (linkf 'whoami? (req) (pr "I am " (get-user req)))) + +;(defop testf req (w/link (pr "ha ha ha") (pr "laugh"))) + +(mac w/link-if (test expr . body) + `(tag-if ,test (a href (flink (fn (,(uniq)) ,expr))) + ,@body)) + +(def fnid-field (id) + (gentag input type 'hidden name 'fnid value id)) + +; f should be a fn of one arg, which will be http request args. + +(def fnform (f bodyfn (o redir)) + (tag (form method 'post action (if redir rfnurl2* fnurl*)) + (fnid-field (fnid f)) + (bodyfn))) + +; Could also make a version that uses just an expr, and var capture. +; Is there a way to ensure user doesn't use "fnid" as a key? + +(mac aform (f . body) + (w/uniq ga + `(tag (form method 'post action fnurl*) + (fnid-field (fnid (fn (,ga) + (prn) + (,f ,ga)))) + ,@body))) + +;(defop test1 req +; (fnform (fn (req) (prn) (pr req)) +; (fn () (single-input "" 'foo 20 "submit")))) + +;(defop test2 req +; (aform (fn (req) (pr req)) +; (single-input "" 'foo 20 "submit"))) + +; Like aform except creates a fnid that will last for lasts seconds +; (unless the server is restarted). + +(mac taform (lasts f . body) + (w/uniq (gl gf gi ga) + `(withs (,gl ,lasts + ,gf (fn (,ga) (prn) (,f ,ga))) + (tag (form method 'post action fnurl*) + (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf))) + ,@body)))) + +(mac arform (f . body) + `(tag (form method 'post action rfnurl*) + (fnid-field (fnid ,f)) + ,@body)) + +; overlong + +(mac tarform (lasts f . body) + (w/uniq (gl gf) + `(withs (,gl ,lasts ,gf ,f) + (tag (form method 'post action rfnurl*) + (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf))) + ,@body)))) + +(mac aformh (f . body) + `(tag (form method 'post action fnurl*) + (fnid-field (fnid ,f)) + ,@body)) + +(mac arformh (f . body) + `(tag (form method 'post action rfnurl2*) + (fnid-field (fnid ,f)) + ,@body)) + +; only unique per server invocation + +(= unique-ids* (table)) + +(def unique-id ((o len 8)) + (let id (sym (rand-string (max 5 len))) + (if (unique-ids* id) + (unique-id) + (= (unique-ids* id) id)))) + +(def srvlog (type . args) + (w/appendfile o (logfile-name type) + (w/stdout o (atomic (apply prs (seconds) args) (prn))))) + +(def logfile-name (type) + (string logdir* type "-" (memodate))) + +(with (lastasked nil lastval nil) + +(def memodate () + (let now (seconds) + (if (or (no lastasked) (> (- now lastasked) 60)) + (= lastasked now lastval (datestring)) + lastval))) + +) + +(defop || req (pr "It's alive.")) + +(defop topips req + (when (admin (get-user req)) + (whitepage + (sptab + (each ip (let leaders nil + (maptable (fn (ip n) + (when (> n 100) + (insort (compare > requests/ip*) + ip + leaders))) + requests/ip*) + leaders) + (let n (requests/ip* ip) + (row ip n (pr (num (* 100 (/ n requests*)) 1))))))))) + +(defop spurned req + (when (admin (get-user req)) + (whitepage + (sptab + (map (fn ((ip n)) (row ip n)) + (sortable spurned*)))))) + +; eventually promote to general util + +(def sortable (ht (o f >)) + (let res nil + (maptable (fn kv + (insort (compare f cadr) kv res)) + ht) + res)) + + +; Background Threads + +(= bgthreads* (table) pending-bgthreads* nil) + +(def new-bgthread (id f sec) + (aif (bgthreads* id) (break-thread it)) + (= (bgthreads* id) (new-thread (fn () + (while t + (sleep sec) + (f)))))) + +; should be a macro for this? + +(mac defbg (id sec . body) + `(do (pull [caris _ ',id] pending-bgthreads*) + (push (list ',id (fn () ,@body) ,sec) + pending-bgthreads*))) + + + +; Idea: make form fields that know their value type because of +; gensymed names, and so the receiving fn gets args that are not +; strings but parsed values. + diff --git a/static/arc.png b/static/arc.png Binary files differnew file mode 100644 index 0000000..100407f --- /dev/null +++ b/static/arc.png diff --git a/static/grayarrow.gif b/static/grayarrow.gif Binary files differnew file mode 100644 index 0000000..888485f --- /dev/null +++ b/static/grayarrow.gif diff --git a/static/graydown.gif b/static/graydown.gif Binary files differnew file mode 100644 index 0000000..0ea7777 --- /dev/null +++ b/static/graydown.gif diff --git a/static/robots.txt b/static/robots.txt new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/static/robots.txt diff --git a/static/s.gif b/static/s.gif Binary files differnew file mode 100644 index 0000000..1d11fa9 --- /dev/null +++ b/static/s.gif diff --git a/strings.arc b/strings.arc new file mode 100644 index 0000000..b80bc59 --- /dev/null +++ b/strings.arc @@ -0,0 +1,226 @@ +; Matching. Spun off 29 Jul 06. + +; arc> (tostring (writec (coerce 133 'char))) +; +;> (define ss (open-output-string)) +;> (write-char (integer->char 133) ss) +;> (get-output-string ss) +;"\u0085" + +(def tokens (s (o sep whitec)) + (let test (testify sep) + (let rec (afn (cs toks tok) + (if (no cs) (consif tok toks) + (test (car cs)) (self (cdr cs) (consif tok toks) nil) + (self (cdr cs) toks (cons (car cs) tok)))) + (rev (map [coerce _ 'string] + (map rev (rec (coerce s 'cons) nil nil))))))) + +; names of cut, split, halve not optimal + +(def halve (s (o sep whitec)) + (let test (testify sep) + (let rec (afn (cs tok) + (if (no cs) (list (rev tok)) + (test (car cs)) (list cs (rev tok)) + (self (cdr cs) (cons (car cs) tok)))) + (rev (map [coerce _ 'string] + (rec (coerce s 'cons) nil)))))) + +; maybe promote to arc.arc, but if so include a list clause + +(def positions (test seq) + (accum a + (let f (testify test) + (forlen i seq + (if (f (seq i)) (a i)))))) + +(def lines (s) + (accum a + ((afn ((p . ps)) + (if ps + (do (a (rem #\return (cut s (+ p 1) (car ps)))) + (self ps)) + (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" + +; first byte: 0-7F, 1 char; c2-df 2; e0-ef 3, f0-f4 4. + +; Fixed for utf8 by pc. + +(def urldecode (s) + (tostring + (forlen i s + (caselet c (s i) + #\+ (writec #\space) + #\% (do (when (> (- (len s) i) 2) + (writeb (int (cut s (+ i 1) (+ i 3)) 16))) + (++ i 2)) + (writec c))))) + +(def urlencode (s) + (tostring + (each c s + (writec #\%) + (let i (int c) + (if (< i 16) (writec #\0)) + (pr (coerce i 'string 16)))))) + +(mac litmatch (pat string (o start 0)) + (w/uniq (gstring gstart) + `(with (,gstring ,string ,gstart ,start) + (unless (> (+ ,gstart ,(len pat)) (len ,gstring)) + (and ,@(let acc nil + (forlen i pat + (push `(is ,(pat i) (,gstring (+ ,gstart ,i))) + acc)) + (rev acc))))))) + +; litmatch would be cleaner if map worked for string and integer args: + +; ,@(map (fn (n c) +; `(is ,c (,gstring (+ ,gstart ,n)))) +; (len pat) +; pat) + +(mac endmatch (pat string) + (w/uniq (gstring glen) + `(withs (,gstring ,string ,glen (len ,gstring)) + (unless (> ,(len pat) (len ,gstring)) + (and ,@(let acc nil + (forlen i pat + (push `(is ,(pat (- (len pat) 1 i)) + (,gstring (- ,glen 1 ,i))) + acc)) + (rev acc))))))) + +(def posmatch (pat seq (o start 0)) + (catch + (if (isa pat 'fn) + (for i start (- (len seq) 1) + (when (pat (seq i)) (throw i))) + (for i start (- (len seq) (len pat)) + (when (headmatch pat seq i) (throw i)))) + nil)) + +(def headmatch (pat seq (o start 0)) + (let p (len pat) + ((afn (i) + (or (is i p) + (and (is (pat i) (seq (+ i start))) + (self (+ i 1))))) + 0))) + +(def begins (seq pat (o start 0)) + (unless (len> pat (- (len seq) start)) + (headmatch pat seq start))) + +(def subst (new old seq) + (let boundary (+ (- (len seq) (len old)) 1) + (tostring + (forlen i seq + (if (and (< i boundary) (headmatch old seq i)) + (do (++ i (- (len old) 1)) + (pr new)) + (pr (seq i))))))) + +(def multisubst (pairs seq) + (tostring + (forlen i seq + (iflet (old new) (find [begins seq (car _) i] pairs) + (do (++ i (- (len old) 1)) + (pr new)) + (pr (seq i)))))) + +; not a good name + +(def findsubseq (pat seq (o start 0)) + (if (< (- (len seq) start) (len pat)) + nil + (if (headmatch pat seq start) + start + (findsubseq pat seq (+ start 1))))) + +(def blank (s) (~find ~whitec s)) + +(def nonblank (s) (unless (blank s) s)) + +(def trim (s (o where 'both) (o test whitec)) + (withs (f (testify test) + p1 (pos ~f s)) + (if p1 + (cut s + (if (in where 'front 'both) p1 0) + (when (in where 'end 'both) + (let i (- (len s) 1) + (while (and (> i p1) (f (s i))) + (-- i)) + (+ i 1)))) + ""))) + +(def num (n (o digits 2) (o trail-zeros nil) (o init-zero nil)) + (withs (comma + (fn (i) + (tostring + (map [apply pr (rev _)] + (rev (intersperse '(#\,) + (tuples (rev (coerce (string i) 'cons)) + 3)))))) + abrep + (let a (abs n) + (if (< digits 1) + (comma (roundup a)) + (exact a) + (string (comma a) + (when (and trail-zeros (> digits 0)) + (string "." (newstring digits #\0)))) + (withs (d (expt 10 digits) + m (/ (roundup (* a d)) d) + i (trunc m) + r (abs (trunc (- (* m d) (* i d))))) + (+ (if (is i 0) + (if (or init-zero (is r 0)) "0" "") + (comma i)) + (withs (rest (string r) + padded (+ (newstring (- digits (len rest)) #\0) + rest) + final (if trail-zeros + padded + (trim padded 'end [is _ #\0]))) + (string (unless (empty final) ".") + final))))))) + (if (and (< n 0) (find [and (digit _) (isnt _ #\0)] abrep)) + (+ "-" abrep) + abrep))) + + +; English + +(def pluralize (n str) + (if (or (is n 1) (single n)) + str + (string str "s"))) + +(def plural (n x) + (string n #\ (pluralize n x))) + + +; http://www.eki.ee/letter/chardata.cgi?HTML4=1 +; http://jrgraphix.net/research/unicode_blocks.php?block=1 +; http://home.tiscali.nl/t876506/utf8tbl.html +; http://www.fileformat.info/info/unicode/block/latin_supplement/utf8test.htm +; http://en.wikipedia.org/wiki/Utf-8 +; http://unicode.org/charts/charindex2.html |
