From 421dc8c7141ecb6297996f7370d96e7e99894683 Mon Sep 17 00:00:00 2001 From: bnewbold Date: Fri, 24 Jun 2011 17:21:45 -0400 Subject: arc3.1.tar --- ac.scm | 1489 ++++++++++++++++++++++++++++ app.arc | 671 +++++++++++++ arc.arc | 1700 ++++++++++++++++++++++++++++++++ as.scm | 16 + blog.arc | 95 ++ brackets.scm | 48 + code.arc | 61 ++ copyright | 2 + how-to-run-news | 44 + html.arc | 415 ++++++++ libs.arc | 7 + news.arc | 2617 ++++++++++++++++++++++++++++++++++++++++++++++++++ pprint.arc | 80 ++ prompt.arc | 119 +++ srv.arc | 573 +++++++++++ static/arc.png | Bin 0 -> 113 bytes static/grayarrow.gif | Bin 0 -> 111 bytes static/graydown.gif | Bin 0 -> 111 bytes static/robots.txt | 0 static/s.gif | Bin 0 -> 43 bytes strings.arc | 226 +++++ 21 files changed, 8163 insertions(+) create mode 100644 ac.scm create mode 100644 app.arc create mode 100644 arc.arc create mode 100644 as.scm create mode 100644 blog.arc create mode 100644 brackets.scm create mode 100644 code.arc create mode 100644 copyright create mode 100644 how-to-run-news create mode 100644 html.arc create mode 100644 libs.arc create mode 100644 news.arc create mode 100644 pprint.arc create mode 100644 prompt.arc create mode 100644 srv.arc create mode 100644 static/arc.png create mode 100644 static/grayarrow.gif create mode 100644 static/graydown.gif create mode 100644 static/robots.txt create mode 100644 static/s.gif create mode 100644 strings.arc diff --git a/ac.scm b/ac.scm new file mode 100644 index 0000000..173ff4a --- /dev/null +++ b/ac.scm @@ -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)) (stringstring x) + (symbol->string y))) + ((and (char? x) (char? y)) (char 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))))) + +) + diff --git a/app.arc b/app.arc new file mode 100644 index 0000000..292800f --- /dev/null +++ b/app.arc @@ -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 "

")
+                 (let cb (code-block s (- newi spaces 1))
+                   (pr cb)
+                   (= i (+ (- newi spaces 1) (len cb))))
+                 (pr "
")) + (iflet newi (parabreak s i (if (is i 0) 1 0)) + (do (unless (is i 0) (pr "

")) + (= 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 "" "")) + (= 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 "

" s i) + (do (++ i 2) + (unless (is i 2) (pr "\n\n"))) + (litmatch "" s i) + (do (++ i 2) (pr #\*)) + (litmatch "" s i) + (do (++ i 3) (pr #\*)) + (litmatch "" s endurl) + (+ it 3) + endurl))) + (writec (s i)))) + (litmatch "

" s i)
+           (awhen (findsubseq "
" 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))))))) + diff --git a/arc.arc b/arc.arc new file mode 100644 index 0000000..ef11fc9 --- /dev/null +++ b/arc.arc @@ -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 + diff --git a/as.scm b/as.scm new file mode 100644 index 0000000..409a9fa --- /dev/null +++ b/as.scm @@ -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 ""))) + +(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 "") + (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 "
")) + (prn)) + +(def br2 () (prn "

")) + +(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 "")) + `(pr ""))) + +;(def spacerow (h) (tr (td (vspace h)))) + +(def spacerow (h) (pr "")) + +; 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 ""))) + +(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 "

")) + (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 "")) + +(mac npage (title . body) + `(tag html + (tag head + (gen-css-url) + (prn "") + (tag script (pr votejs*)) + (tag title (pr ,title))) + (tag body + (center + (tag (table border 0 cellpadding 0 cellspacing 0 width "85%" + bgcolor sand) + ,@body))))) + +(= pagefns* nil) + +(mac fulltop (user lid label title whence . body) + (w/uniq (gu gi gl gt gw) + `(with (,gu ,user ,gi ,lid ,gl ,label ,gt ,title ,gw ,whence) + (npage (+ this-site* (if ,gt (+ bar* ,gt) "")) + (if (check-procrast ,gu) + (do (pagetop 'full ,gi ,gl ,gt ,gu ,gw) + (hook 'page ,gu ,gl) + ,@body) + (row (procrast-msg ,gu ,gw))))))) + +(mac longpage (user t1 lid label title whence . body) + (w/uniq (gu gt gi) + `(with (,gu ,user ,gt ,t1 ,gi ,lid) + (fulltop ,gu ,gi ,label ,title ,whence + (trtd ,@body) + (trtd (vspace 10) + (color-stripe (main-color ,gu)) + (br) + (center + (hook 'longfoot) + (admin-bar ,gu (- (msec) ,gt) ,whence))))))) + +(def admin-bar (user elapsed whence) + (when (admin user) + (br2) + (w/bars + (pr (len items*) "/" maxid* " loaded") + (pr (round (/ (memory) 1000000)) " mb") + (pr elapsed " msec") + (link "settings" "newsadmin") + (hook 'admin-bar user whence)))) + +(def color-stripe (c) + (tag (table width "100%" cellspacing 0 cellpadding 1) + (tr (tdcolor c)))) + +(mac shortpage (user lid label title whence . body) + `(fulltop ,user ,lid ,label ,title ,whence + (trtd ,@body))) + +(mac minipage (label . body) + `(npage (+ this-site* bar* ,label) + (pagetop nil nil ,label) + (trtd ,@body))) + +(def msgpage (user msg (o title)) + (minipage (or title "Message") + (spanclass admin + (center (if (len> msg 80) + (widtable 500 msg) + (pr msg)))) + (br2))) + +(= (max-age* 'news.css) 86400) ; cache css in browser for 1 day + +; turn off server caching via (= caching* 0) or won't see changes + +(defop news.css req + (pr " +body { font-family:Verdana; font-size:10pt; color:#828282; } +td { font-family:Verdana; font-size:10pt; color:#828282; } + +.admin td { font-family:Verdana; font-size:8.5pt; color:#000000; } +.subtext td { font-family:Verdana; font-size: 7pt; color:#828282; } + +input { font-family:Courier; font-size:10pt; color:#000000; } +input[type=\"submit\"] { font-family:Verdana; } +textarea { font-family:Courier; font-size:10pt; color:#000000; } + +a:link { color:#000000; text-decoration:none; } +a:visited { color:#828282; text-decoration:none; } + +.default { font-family:Verdana; font-size: 10pt; color:#828282; } +.admin { font-family:Verdana; font-size:8.5pt; color:#000000; } +.title { font-family:Verdana; font-size: 10pt; color:#828282; } +.adtitle { font-family:Verdana; font-size: 9pt; color:#828282; } +.subtext { font-family:Verdana; font-size: 7pt; color:#828282; } +.yclinks { font-family:Verdana; font-size: 8pt; color:#828282; } +.pagetop { font-family:Verdana; font-size: 10pt; color:#222222; } +.comhead { font-family:Verdana; font-size: 8pt; color:#828282; } +.comment { font-family:Verdana; font-size: 9pt; } +.dead { font-family:Verdana; font-size: 9pt; color:#dddddd; } + +.comment a:link, .comment a:visited { text-decoration:underline;} +.dead a:link, .dead a:visited { color:#dddddd; } +.pagetop a:visited { color:#000000;} +.topsel a:link, .topsel a:visited { color:#ffffff; } + +.subtext a:link, .subtext a:visited { color:#828282; } +.subtext a:hover { text-decoration:underline; } + +.comhead a:link, .subtext a:visited { color:#828282; } +.comhead a:hover { text-decoration:underline; } + +.default p { margin-top: 8px; margin-bottom: 0px; } + +.pagebreak {page-break-before:always} + +pre { overflow: auto; padding: 2px; max-width:600px; } +pre:hover {overflow:auto} ")) + +; only need pre padding because of a bug in Mac Firefox + +; Without setting the bottom margin of p tags to 0, 1- and n-para comments +; have different space at the bottom. This solution suggested by Devin. +; Really am using p tags wrong (as separators rather than wrappers) and the +; correct thing to do would be to wrap each para in

. Then whatever +; I set the bottom spacing to, it would be the same no matter how many paras +; in a comment. In this case by setting the bottom spacing of p to 0, I'm +; making it the same as no p, which is what the first para has. + +; supplied by pb +;.vote { padding-left:2px; vertical-align:top; } +;.comment { margin-top:1ex; margin-bottom:1ex; color:black; } +;.vote IMG { border:0; margin: 3px 2px 3px 2px; } +;.reply { font-size:smaller; text-decoration:underline !important; } + +(= votejs* " +function byId(id) { + return document.getElementById(id); +} + +function vote(node) { + var v = node.id.split(/_/); // {'up', '123'} + var item = v[1]; + + // adjust score + var score = byId('score_' + item); + var newscore = parseInt(score.innerHTML) + (v[0] == 'up' ? 1 : -1); + score.innerHTML = newscore + (newscore == 1 ? ' point' : ' points'); + + // hide arrows + byId('up_' + item).style.visibility = 'hidden'; + byId('down_' + item).style.visibility = 'hidden'; + + // ping server + var ping = new Image(); + ping.src = node.href; + + return false; // cancel browser nav +} ") + + +; Page top + +(= sand (color 246 246 239) textgray (gray 130)) + +(def main-color (user) + (aif (and user (uvar user topcolor)) + (hex>color it) + site-color*)) + +(def pagetop (switch lid label (o title) (o user) (o whence)) +; (tr (tdcolor black (vspace 5))) + (tr (tdcolor (main-color user) + (tag (table border 0 cellpadding 0 cellspacing 0 width "100%" + style "padding:2px") + (tr (gen-logo) + (when (is switch 'full) + (tag (td style "line-height:12pt; height:10px;") + (spanclass pagetop + (tag b (link this-site* "news")) + (hspace 10) + (toprow user label)))) + (if (is switch 'full) + (tag (td style "text-align:right;padding-right:4px;") + (spanclass pagetop (topright user whence))) + (tag (td style "line-height:12pt; height:10px;") + (spanclass pagetop (prbold label)))))))) + (map [_ user] pagefns*) + (spacerow 10)) + +(def gen-logo () + (tag (td style "width:18px;padding-right:4px") + (tag (a href parent-url*) + (tag (img src logo-url* width 18 height 18 + style "border:1px #@(hexrep border-color*) solid;"))))) + +(= toplabels* '(nil "welcome" "new" "threads" "comments" "leaders" "*")) + +; redefined later + +(= welcome-url* "welcome") + +(def toprow (user label) + (w/bars + (when (noob user) + (toplink "welcome" welcome-url* label)) + (toplink "new" "newest" label) + (when user + (toplink "threads" (threads-url user) label)) + (toplink "comments" "newcomments" label) + (toplink "leaders" "leaders" label) + (hook 'toprow user label) + (link "submit") + (unless (mem label toplabels*) + (fontcolor white (pr label))))) + +(def toplink (name dest label) + (tag-if (is name label) (span class 'topsel) + (link name dest))) + +(def topright (user whence (o showkarma t)) + (when user + (userlink user user nil) + (when showkarma (pr " (@(karma user))")) + (pr " | ")) + (if user + (rlinkf 'logout (req) + (when-umatch/r user req + (logout-user user) + whence)) + (onlink "login" + (login-page 'both nil + (list (fn (u ip) + (ensure-news-user u) + (newslog ip u 'top-login)) + whence))))) + +(def noob (user) + (and user (< (days-since (uvar user created)) 1))) + + +; News-Specific Defop Variants + +(mac defopt (name parm test msg . body) + `(defop ,name ,parm + (if (,test (get-user ,parm)) + (do ,@body) + (login-page 'both (+ "Please log in" ,msg ".") + (list (fn (u ip) (ensure-news-user u)) + (string ',name (reassemble-args ,parm))))))) + +(mac defopg (name parm . body) + `(defopt ,name ,parm idfn "" ,@body)) + +(mac defope (name parm . body) + `(defopt ,name ,parm editor " as an editor" ,@body)) + +(mac defopa (name parm . body) + `(defopt ,name ,parm admin " as an administrator" ,@body)) + +(mac opexpand (definer name parms . body) + (w/uniq gr + `(,definer ,name ,gr + (with (user (get-user ,gr) ip (,gr 'ip)) + (with ,(and parms (mappend [list _ (list 'arg gr (string _))] + parms)) + (newslog ip user ',name ,@parms) + ,@body))))) + +(= newsop-names* nil) + +(mac newsop args + `(do (pushnew ',(car args) newsop-names*) + (opexpand defop ,@args))) + +(mac adop (name parms . body) + (w/uniq g + `(opexpand defopa ,name ,parms + (let ,g (string ',name) + (shortpage user nil ,g ,g ,g + ,@body))))) + +(mac edop (name parms . body) + (w/uniq g + `(opexpand defope ,name ,parms + (let ,g (string ',name) + (shortpage user nil ,g ,g ,g + ,@body))))) + + +; News Admin + +(defopa newsadmin req + (let user (get-user req) + (newslog req!ip user 'newsadmin) + (newsadmin-page user))) + +; Note that caching* is reset to val in source when restart server. + +(def nad-fields () + `((num caching ,caching* t t) + (bigtoks comment-kill ,comment-kill* t t) + (bigtoks comment-ignore ,comment-ignore* t t) + (bigtoks lightweights ,(sort < (keys lightweights*)) t t))) + +; Need a util like vars-form for a collection of variables. +; Or could generalize vars-form to think of places (in the setf sense). + +(def newsadmin-page (user) + (shortpage user nil nil "newsadmin" "newsadmin" + (vars-form user + (nad-fields) + (fn (name val) + (case name + caching (= caching* val) + comment-kill (todisk comment-kill* val) + comment-ignore (todisk comment-ignore* val) + lightweights (todisk lightweights* (memtable val)) + )) + (fn () (newsadmin-page user))) + (br2) + (aform (fn (req) + (with (user (get-user req) subject (arg req "id")) + (if (profile subject) + (do (killallby subject) + (submitted-page user subject)) + (admin&newsadmin-page user)))) + (single-input "" 'id 20 "kill all by")) + (br2) + (aform (fn (req) + (let user (get-user req) + (set-ip-ban user (arg req "ip") t) + (admin&newsadmin-page user))) + (single-input "" 'ip 20 "ban ip")))) + + +; Users + +(newsop user (id) + (if (only.profile id) + (user-page user id) + (pr "No such user."))) + +(def user-page (user subject) + (let here (user-url subject) + (shortpage user nil nil (+ "Profile: " subject) here + (profile-form user subject) + (br2) + (when (some astory:item (uvar subject submitted)) + (underlink "submissions" (submitted-url subject))) + (when (some acomment:item (uvar subject submitted)) + (sp) + (underlink "comments" (threads-url subject))) + (hook 'user user subject)))) + +(def profile-form (user subject) + (let prof (profile subject) + (vars-form user + (user-fields user subject) + (fn (name val) + (when (and (is name 'ignore) val (no prof!ignore)) + (log-ignore user subject 'profile)) + (= (prof name) val)) + (fn () (save-prof subject) + (user-page user subject))))) + +(= topcolor-threshold* 250) + +(def user-fields (user subject) + (withs (e (editor user) + a (admin user) + w (is user subject) + k (and w (> (karma user) topcolor-threshold*)) + u (or a w) + m (or a (and (member user) w)) + p (profile subject)) + `((string user ,subject t nil) + (string name ,(p 'name) ,m ,m) + (string created ,(text-age:user-age subject) t nil) + (string password ,(resetpw-link) ,w nil) + (string saved ,(saved-link user subject) ,u nil) + (int auth ,(p 'auth) ,e ,a) + (yesno member ,(p 'member) ,a ,a) + (posint karma ,(p 'karma) t ,a) + (num avg ,(p 'avg) ,a nil) + (yesno ignore ,(p 'ignore) ,e ,e) + (num weight ,(p 'weight) ,a ,a) + (mdtext2 about ,(p 'about) t ,u) + (string email ,(p 'email) ,u ,u) + (yesno showdead ,(p 'showdead) ,u ,u) + (yesno noprocrast ,(p 'noprocrast) ,u ,u) + (string firstview ,(p 'firstview) ,a nil) + (string lastview ,(p 'lastview) ,a nil) + (posint maxvisit ,(p 'maxvisit) ,u ,u) + (posint minaway ,(p 'minaway) ,u ,u) + (sexpr keys ,(p 'keys) ,a ,a) + (hexcol topcolor ,(or (p 'topcolor) (hexrep site-color*)) ,k ,k) + (int delay ,(p 'delay) ,u ,u)))) + +(def saved-link (user subject) + (when (or (admin user) (is user subject)) + (let n (if (len> (votes subject) 500) + "many" + (len (voted-stories user subject))) + (if (is n 0) + "" + (tostring (underlink n (saved-url subject))))))) + +(def resetpw-link () + (tostring (underlink "reset password" "resetpw"))) + +(newsop welcome () + (pr "Welcome to " this-site* ", " user "!")) + + +; Main Operators + +; remember to set caching to 0 when testing non-logged-in + +(= caching* 1 perpage* 30 threads-perpage* 10 maxend* 210) + +; Limiting that newscache can't take any arguments except the user. +; To allow other arguments, would have to turn the cache from a single +; stored value to a hash table whose keys were lists of arguments. + +(mac newscache (name user time . body) + (w/uniq gc + `(let ,gc (cache (fn () (* caching* ,time)) + (fn () (tostring (let ,user nil ,@body)))) + (def ,name (,user) + (if ,user + (do ,@body) + (pr (,gc))))))) + + +(newsop news () (newspage user)) + +(newsop || () (newspage user)) + +;(newsop index.html () (newspage user)) + +(newscache newspage user 90 + (listpage user (msec) (topstories user maxend*) nil nil "news")) + +(def listpage (user t1 items label title (o url label) (o number t)) + (hook 'listpage user) + (longpage user t1 nil label title url + (display-items user items label title url 0 perpage* number))) + + +(newsop newest () (newestpage user)) + +; Note: dead/deleted items will persist for the remaining life of the +; cached page. If this were a prob, could make deletion clear caches. + +(newscache newestpage user 40 + (listpage user (msec) (newstories user maxend*) "new" "New Links" "newest")) + +(def newstories (user n) + (retrieve n [cansee user _] stories*)) + + +(newsop best () (bestpage user)) + +(newscache bestpage user 1000 + (listpage user (msec) (beststories user maxend*) "best" "Top Links")) + +; As no of stories gets huge, could test visibility in fn sent to best. + +(def beststories (user n) + (bestn n (compare > realscore) (visible user stories*))) + + +(newsop noobstories () (noobspage user stories*)) +(newsop noobcomments () (noobspage user comments*)) + +(def noobspage (user source) + (listpage user (msec) (noobs user maxend* source) "noobs" "New Accounts")) + +(def noobs (user n source) + (retrieve n [and (cansee user _) (bynoob _)] source)) + +(def bynoob (i) + (< (- (user-age i!by) (item-age i)) 2880)) + + +(newsop bestcomments () (bestcpage user)) + +(newscache bestcpage user 1000 + (listpage user (msec) (bestcomments user maxend*) + "best comments" "Best Comments" "bestcomments" nil)) + +(def bestcomments (user n) + (bestn n (compare > realscore) (visible user comments*))) + + +(newsop lists () + (longpage user (msec) nil "lists" "Lists" "lists" + (sptab + (row (link "best") "Highest voted recent links.") + (row (link "active") "Most active current discussions.") + (row (link "bestcomments") "Highest voted recent comments.") + (row (link "noobstories") "Submissions from new accounts.") + (row (link "noobcomments") "Comments from new accounts.") + (when (admin user) + (map row:link + '(optimes topips flagged killed badguys badlogins goodlogins))) + (hook 'listspage user)))) + + +(def saved-url (user) (+ "saved?id=" user)) + +(newsop saved (id) + (if (only.profile id) + (savedpage user id) + (pr "No such user."))) + +(def savedpage (user subject) + (if (or (is user subject) (admin user)) + (listpage user (msec) + (sort (compare < item-age) (voted-stories user subject)) + "saved" "Saved Links" (saved-url subject)) + (pr "Can't display that."))) + +(def voted-stories (user subject) + (keep [and (astory _) (cansee user _)] + (map item (keys:votes subject)))) + + +; Story Display + +(def display-items (user items label title whence + (o start 0) (o end perpage*) (o number)) + (zerotable + (let n start + (each i (cut items start end) + (display-item (and number (++ n)) i user whence t) + (spacerow (if (acomment i) 15 5)))) + (when end + (let newend (+ end perpage*) + (when (and (<= newend maxend*) (< end (len items))) + (spacerow 10) + (tr (tag (td colspan (if number 2 1))) + (tag (td class 'title) + (morelink display-items + items label title end newend number)))))))) + +; This code is inevitably complex because the More fn needs to know +; its own fnid in order to supply a correct whence arg to stuff on +; the page it generates, like logout and delete links. + +(def morelink (f items label title . args) + (tag (a href + (url-for + (afnid (fn (req) + (prn) + (with (url (url-for it) ; it bound by afnid + user (get-user req)) + (newslog req!ip user 'more label) + (longpage user (msec) nil label title url + (apply f user items label title url args)))))) + rel 'nofollow) + (pr "More"))) + +(def display-story (i s user whence) + (when (or (cansee user s) (s 'kids)) + (tr (display-item-number i) + (td (votelinks s user whence)) + (titleline s s!url user whence)) + (tr (tag (td colspan (if i 2 1))) + (tag (td class 'subtext) + (hook 'itemline s user) + (itemline s user) + (when (in s!type 'story 'poll) (commentlink s user)) + (editlink s user) + (when (apoll s) (addoptlink s user)) + (unless i (flaglink s user whence)) + (killlink s user whence) + (blastlink s user whence) + (blastlink s user whence t) + (deletelink s user whence))))) + +(def display-item-number (i) + (when i (tag (td align 'right valign 'top class 'title) + (pr i ".")))) + +(= follow-threshold* 5) + +(def titleline (s url user whence) + (tag (td class 'title) + (if (cansee user s) + (do (deadmark s user) + (titlelink s url user) + (pdflink url) + (awhen (sitename url) + (spanclass comhead + (pr " (" ) + (if (admin user) + (w/rlink (do (set-site-ban user + it + (case (car (banned-sites* it)) + nil 'ignore + ignore 'kill + kill nil)) + whence) + (let ban (car (banned-sites* it)) + (tag-if ban (font color (case ban + ignore darkred + kill darkblue)) + (pr it)))) + (pr it)) + (pr ") ")))) + (pr (pseudo-text s))))) + +(def titlelink (s url user) + (let toself (blank url) + (tag (a href (if toself + (item-url s!id) + (or (live s) (author user s) (editor user)) + url + nil) + rel (unless (or toself (> (realscore s) follow-threshold*)) + 'nofollow)) + (pr s!title)))) + +(def pdflink (url) + (awhen (vacuumize url) + (pr " [") + (link "scribd" it) + (pr "]"))) + +(defmemo vacuumize (url) + (and (or (endmatch ".pdf" url) (endmatch ".PDF" url)) + (+ "http://www.scribd.com/vacuum?url=" url))) + +(def pseudo-text (i) + (if i!deleted "[deleted]" "[dead]")) + +(def deadmark (i user) + (when (and i!dead (seesdead user)) + (pr " [dead] ")) + (when (and i!deleted (admin user)) + (pr " [deleted] "))) + +(= downvote-threshold* 200 downvote-time* 1440) + +(= votewid* 14) + +(def votelinks (i user whence (o downtoo)) + (center + (if (and (cansee user i) + (or (no user) + (no ((votes user) i!id)))) + (do (votelink i user whence 'up) + (if (and downtoo + (or (admin user) + (< (item-age i) downvote-time*)) + (canvote user i 'down)) + (do (br) + (votelink i user whence 'down)) + ; don't understand why needed, but is, or a new + ; page is generated on voting + (tag (span id (+ "down_" i!id))))) + (author user i) + (do (fontcolor orange (pr "*")) + (br) + (hspace votewid*)) + (hspace votewid*)))) + +; could memoize votelink more, esp for non-logged in users, +; since only uparrow is shown; could straight memoize + +; redefined later (identically) so the outs catch new vals of up-url, etc. + +(def votelink (i user whence dir) + (tag (a id (if user (string dir '_ i!id)) + onclick (if user "return vote(this)") + href (vote-url user i dir whence)) + (if (is dir 'up) + (out (gentag img src up-url* border 0 vspace 3 hspace 2)) + (out (gentag img src down-url* border 0 vspace 3 hspace 2))))) + +(def vote-url (user i dir whence) + (+ "vote?" "for=" i!id + "&dir=" dir + (if user (+ "&by=" user "&auth=" (user->cookie* user))) + "&whence=" (urlencode whence))) + +(= lowest-score* -4) + +; Not much stricter than whether to generate the arrow. Further tests +; applied in vote-for. + +(def canvote (user i dir) + (and user + (news-type&live i) + (or (is dir 'up) (> i!score lowest-score*)) + (no ((votes user) i!id)) + (or (is dir 'up) + (and (acomment i) + (> (karma user) downvote-threshold*) + (no (aand i!parent (author user (item it)))))))) + +; Need the by argument or someone could trick logged in users into +; voting something up by clicking on a link. But a bad guy doesn't +; know how to generate an auth arg that matches each user's cookie. + +(newsop vote (by for dir auth whence) + (with (i (safe-item for) + dir (saferead dir) + whence (if whence (urldecode whence) "news")) + (if (no i) + (pr "No such item.") + (no (in dir 'up 'down)) + (pr "Can't make that vote.") + (and by (or (isnt by user) (isnt (sym auth) (user->cookie* user)))) + (pr "User mismatch.") + (no user) + (login-page 'both "You have to be logged in to vote." + (list (fn (u ip) + (ensure-news-user u) + (newslog ip u 'vote-login) + (when (canvote u i dir) + (vote-for u i dir) + (logvote ip u i))) + whence)) + (canvote user i dir) + (do (vote-for by i dir) + (logvote ip by i)) + (pr "Can't make that vote.")))) + +(def itemline (i user) + (when (cansee user i) + (when (news-type i) (itemscore i user)) + (byline i user))) + +(def itemscore (i (o user)) + (tag (span id (+ "score_" i!id)) + (pr (plural (if (is i!type 'pollopt) (realscore i) i!score) + "point"))) + (hook 'itemscore i user)) + +; redefined later + +(def byline (i user) + (pr " by @(tostring (userlink user i!by)) @(text-age:item-age i) ")) + +(def user-url (user) (+ "user?id=" user)) + +(= show-avg* nil) + +(def userlink (user subject (o show-avg t)) + (link (user-name user subject) (user-url subject)) + (awhen (and show-avg* (admin user) show-avg (uvar subject avg)) + (pr " (@(num it 1 t t))"))) + +(= noob-color* (color 60 150 60)) + +(def user-name (user subject) + (if (and (editor user) (ignored subject)) + (tostring (fontcolor darkred (pr subject))) + (and (editor user) (< (user-age subject) 1440)) + (tostring (fontcolor noob-color* (pr subject))) + subject)) + +(= show-threadavg* nil) + +(def commentlink (i user) + (when (cansee user i) + (pr bar*) + (tag (a href (item-url i!id)) + (let n (- (visible-family user i) 1) + (if (> n 0) + (do (pr (plural n "comment")) + (awhen (and show-threadavg* (admin user) (threadavg i)) + (pr " (@(num it 1 t t))"))) + (pr "discuss")))))) + +(def visible-family (user i) + (+ (if (cansee user i) 1 0) + (sum [visible-family user (item _)] i!kids))) + +(def threadavg (i) + (only.avg (map [or (uvar _ avg) 1] + (rem admin (dedup (map !by (keep live (family i)))))))) + +(= user-changetime* 120 editor-changetime* 1440) + +(= everchange* (table) noedit* (table)) + +(def canedit (user i) + (or (admin user) + (and (~noedit* i!type) + (editor user) + (< (item-age i) editor-changetime*)) + (own-changeable-item user i))) + +(def own-changeable-item (user i) + (and (author user i) + (~mem 'locked i!keys) + (no i!deleted) + (or (everchange* i!type) + (< (item-age i) user-changetime*)))) + +(def editlink (i user) + (when (canedit user i) + (pr bar*) + (link "edit" (edit-url i)))) + +(def addoptlink (p user) + (when (or (admin user) (author user p)) + (pr bar*) + (onlink "add choice" (add-pollopt-page p user)))) + +; reset later + +(= flag-threshold* 30 flag-kill-threshold* 7 many-flags* 1) + +; Un-flagging something doesn't unkill it, if it's now no longer +; over flag-kill-threshold. Ok, since arbitrary threshold anyway. + +(def flaglink (i user whence) + (when (and user + (isnt user i!by) + (or (admin user) (> (karma user) flag-threshold*))) + (pr bar*) + (w/rlink (do (togglemem user i!flags) + (when (and (~mem 'nokill i!keys) + (len> i!flags flag-kill-threshold*) + (< (realscore i) 10) + (~find admin:!2 i!vote)) + (kill i 'flags)) + whence) + (pr "@(if (mem user i!flags) 'un)flag")) + (when (and (admin user) (len> i!flags many-flags*)) + (pr bar* (plural (len i!flags) "flag") " ") + (w/rlink (do (togglemem 'nokill i!keys) + (save-item i) + whence) + (pr (if (mem 'nokill i!keys) "un-notice" "noted")))))) + +(def killlink (i user whence) + (when (admin user) + (pr bar*) + (w/rlink (do (zap no i!dead) + (if i!dead + (do (pull 'nokill i!keys) + (log-kill i user)) + (pushnew 'nokill i!keys)) + (save-item i) + whence) + (pr "@(if i!dead 'un)kill")))) + +; Blast kills the submission and bans the user. Nuke also bans the +; site, so that all future submitters will be ignored. Does not ban +; the ip address, but that will eventually get banned by maybe-ban-ip. + +(def blastlink (i user whence (o nuke)) + (when (and (admin user) + (or (no nuke) (~empty i!url))) + (pr bar*) + (w/rlink (do (toggle-blast i user nuke) + whence) + (prt (if (ignored i!by) "un-") (if nuke "nuke" "blast"))))) + +(def toggle-blast (i user (o nuke)) + (atomic + (if (ignored i!by) + (do (wipe i!dead (ignored i!by)) + (awhen (and nuke (sitename i!url)) + (set-site-ban user it nil))) + (do (set i!dead) + (ignore user i!by (if nuke 'nuke 'blast)) + (awhen (and nuke (sitename i!url)) + (set-site-ban user it 'ignore)))) + (if i!dead (log-kill i user)) + (save-item i) + (save-prof i!by))) + +(def candelete (user i) + (or (admin user) (own-changeable-item user i))) + +(def deletelink (i user whence) + (when (candelete user i) + (pr bar*) + (linkf (if i!deleted "undelete" "delete") (req) + (let user (get-user req) + (if (candelete user i) + (del-confirm-page user i whence) + (prn "You can't delete that.")))))) + +; Undeleting stories could cause a slight inconsistency. If a story +; linking to x gets deleted, another submission can take its place in +; url->story. If the original is then undeleted, there will be two +; stories with equal claim to be in url->story. (The more recent will +; win because it happens to get loaded later.) Not a big problem. + +(def del-confirm-page (user i whence) + (minipage "Confirm" + (tab + ; link never used so not testable but think correct + (display-item nil i user (flink [del-confirm-page (get-user _) i whence])) + (spacerow 20) + (tr (td) + (td (urform user req + (do (when (candelete user i) + (= i!deleted (is (arg req "b") "Yes")) + (save-item i)) + whence) + (prn "Do you want this to @(if i!deleted 'stay 'be) deleted?") + (br2) + (but "Yes" "b") (sp) (but "No" "b"))))))) + +(def permalink (story user) + (when (cansee user story) + (pr bar*) + (link "link" (item-url story!id)))) + +(def logvote (ip user story) + (newslog ip user 'vote (story 'id) (list (story 'title)))) + +(def text-age (a) + (tostring + (if (>= a 1440) (pr (plural (trunc (/ a 1440)) "day") " ago") + (>= a 60) (pr (plural (trunc (/ a 60)) "hour") " ago") + (pr (plural (trunc a) "minute") " ago")))) + + +; Voting + +; A user needs legit-threshold karma for a vote to count if there has +; already been a vote from the same IP address. A new account below both +; new- thresholds won't affect rankings, though such votes still affect +; scores unless not a legit-user. + +(= legit-threshold* 0 new-age-threshold* 0 new-karma-threshold* 2) + +(def legit-user (user) + (or (editor user) + (> (karma user) legit-threshold*))) + +(def possible-sockpuppet (user) + (or (ignored user) + (< (uvar user weight) .5) + (and (< (user-age user) new-age-threshold*) + (< (karma user) new-karma-threshold*)))) + +(= downvote-ratio-limit* .65 recent-votes* nil votewindow* 100) + +; Note: if vote-for by one user changes (s 'score) while s is being +; edited by another, the save after the edit will overwrite the change. +; Actual votes can't be lost because that field is not editable. Not a +; big enough problem to drag in locking. + +(def vote-for (user i (o dir 'up)) + (unless (or ((votes user) i!id) + (and (~live i) (isnt user i!by))) + (withs (ip (logins* user) + vote (list (seconds) ip user dir i!score)) + (unless (or (and (or (ignored user) (check-key user 'novote)) + (isnt user i!by)) + (and (is dir 'down) + (~editor user) + (or (check-key user 'nodowns) + (> (downvote-ratio user) downvote-ratio-limit*) + ; prevention of karma-bombing + (just-downvoted user i!by))) + (and (~legit-user user) + (isnt user i!by) + (find [is (cadr _) ip] i!votes)) + (and (isnt i!type 'pollopt) + (biased-voter i vote))) + (++ i!score (case dir up 1 down -1)) + ; canvote protects against sockpuppet downvote of comments + (when (and (is dir 'up) (possible-sockpuppet user)) + (++ i!sockvotes)) + (metastory&adjust-rank i) + (unless (or (author user i) + (and (is ip i!ip) (~editor user)) + (is i!type 'pollopt)) + (++ (karma i!by) (case dir up 1 down -1)) + (save-prof i!by)) + (wipe (comment-cache* i!id))) + (if (admin user) (pushnew 'nokill i!keys)) + (push vote i!votes) + (save-item i) + (push (list (seconds) i!id i!by (sitename i!url) dir) + (uvar user votes)) + (= ((votes* user) i!id) vote) + (save-votes user) + (zap [firstn votewindow* _] (uvar user votes)) + (save-prof user) + (push (cons i!id vote) recent-votes*)))) + +; redefined later + +(def biased-voter (i vote) nil) + +; ugly to access vote fields by position number + +(def downvote-ratio (user (o sample 20)) + (ratio [is _.1.3 'down] + (keep [let by ((item (car _)) 'by) + (nor (is by user) (ignored by))] + (bestn sample (compare > car:cadr) (tablist (votes user)))))) + +(def just-downvoted (user victim (o n 3)) + (let prev (firstn n (recent-votes-by user)) + (and (is (len prev) n) + (all (fn ((id sec ip voter dir score)) + (and (author victim (item id)) (is dir 'down))) + prev)))) + +; Ugly to pluck out fourth element. Should read votes into a vote +; template. They're stored slightly differently in two diff places: +; in one with the voter in the car and the other without. + +(def recent-votes-by (user) + (keep [is _.3 user] recent-votes*)) + + +; Story Submission + +(newsop submit () + (if user + (submit-page user "" "" t) + (submit-login-warning "" "" t))) + +(def submit-login-warning ((o url) (o title) (o showtext) (o text)) + (login-page 'both "You have to be logged in to submit." + (fn (user ip) + (ensure-news-user user) + (newslog ip user 'submit-login) + (submit-page user url title showtext text)))) + +(def submit-page (user (o url) (o title) (o showtext) (o text "") (o msg)) + (minipage "Submit" + (pagemessage msg) + (urform user req + (process-story (get-user req) + (clean-url (arg req "u")) + (striptags (arg req "t")) + showtext + (and showtext (md-from-form (arg req "x") t)) + req!ip) + (tab + (row "title" (input "t" title 50)) + (if prefer-url* + (do (row "url" (input "u" url 50)) + (when showtext + (row "" "or") + (row "text" (textarea "x" 4 50 (only.pr text))))) + (do (row "text" (textarea "x" 4 50 (only.pr text))) + (row "" "or") + (row "url" (input "u" url 50)))) + (row "" (submit)) + (spacerow 20) + (row "" submit-instructions*))))) + +(= submit-instructions* + "Leave url blank to submit a question for discussion. If there is + no url, the text (if any) will appear at the top of the comments + page. If there is a url, the text will be ignored.") + +; For use by outside code like bookmarklet. +; http://news.domain.com/submitlink?u=http://foo.com&t=Foo +; Added a confirm step to avoid xss hacks. + +(newsop submitlink (u t) + (if user + (submit-page user u t) + (submit-login-warning u t))) + +(= title-limit* 80 + retry* "Please try again." + toolong* "Please make title < @title-limit* characters." + bothblank* "The url and text fields can't both be blank. Please + either supply a url, or if you're asking a question, + put it in the text field." + toofast* "You're submitting too fast. Please slow down. Thanks." + spammage* "Stop spamming us. You're wasting your time.") + +; Only for annoyingly high-volume spammers. For ordinary spammers it's +; enough to ban their sites and ip addresses. + +(disktable big-spamsites* (+ newsdir* "big-spamsites")) + +(def process-story (user url title showtext text ip) + (aif (and (~blank url) (live-story-w/url url)) + (do (vote-for user it) + (item-url it!id)) + (if (no user) + (flink [submit-login-warning url title showtext text]) + (no (and (or (blank url) (valid-url url)) + (~blank title))) + (flink [submit-page user url title showtext text retry*]) + (len> title title-limit*) + (flink [submit-page user url title showtext text toolong*]) + (and (blank url) (blank text)) + (flink [submit-page user url title showtext text bothblank*]) + (let site (sitename url) + (or (big-spamsites* site) (recent-spam site))) + (flink [msgpage user spammage*]) + (oversubmitting user ip 'story url) + (flink [msgpage user toofast*]) + (let s (create-story url (process-title title) text user ip) + (story-ban-test user s ip url) + (when (ignored user) (kill s 'ignored)) + (submit-item user s) + (maybe-ban-ip s) + "newest")))) + +(def submit-item (user i) + (push i!id (uvar user submitted)) + (save-prof user) + (vote-for user i)) + +(def recent-spam (site) + (and (caris (banned-sites* site) 'ignore) + (recent-items [is (sitename _!url) site] 720))) + +(def recent-items (test minutes) + (let cutoff (- (seconds) (* 60 minutes)) + (latest-items test [< _!time cutoff]))) + +; Turn this on when spam becomes a problem. + +(= enforce-oversubmit* nil) + +; New user can't submit more than 2 stories in a 2 hour period. +; Give overeager users the key toofast to make limit permanent. + +(def oversubmitting (user ip kind (o url)) + (and enforce-oversubmit* + (or (check-key user 'toofast) + (ignored user) + (< (user-age user) new-age-threshold*) + (< (karma user) new-karma-threshold*)) + (len> (recent-items [or (author user _) (is _!ip ip)] 180) + (if (is kind 'story) + (if (bad-user user) 0 1) + (if (bad-user user) 1 10))))) + +; Note that by deliberate tricks, someone could submit a story with a +; blank title. + +(diskvar scrubrules* (+ newsdir* "scrubrules")) + +(def process-title (s) + (let s2 (multisubst scrubrules* s) + (zap upcase (s2 0)) + s2)) + +(def live-story-w/url (url) + (aand (url->story* (canonical-url url)) (check (item it) live))) + +(def parse-site (url) + (rev (tokens (cadr (tokens url [in _ #\/ #\?])) #\.))) + +(defmemo sitename (url) + (and (valid-url url) + (let toks (parse-site (rem #\space url)) + (if (isa (saferead (car toks)) 'int) + (tostring (prall toks "" ".")) + (let (t1 t2 t3 . rest) toks + (if (and (~in t3 nil "www") + (or (mem t1 multi-tld-countries*) + (mem t2 long-domains*))) + (+ t3 "." t2 "." t1) + (and t2 (+ t2 "." t1)))))))) + +(= multi-tld-countries* '("uk" "jp" "au" "in" "ph" "tr" "za" "my" "nz" "br" + "mx" "th" "sg" "id" "pk" "eg" "il" "at" "pl")) + +(= long-domains* '("blogspot" "wordpress" "livejournal" "blogs" "typepad" + "weebly" "posterous" "blog-city" "supersized" "dreamhosters" + ; "sampasite" "multiply" "wetpaint" ; all spam, just ban + "eurekster" "blogsome" "edogo" "blog" "com")) + +(def create-story (url title text user ip) + (newslog ip user 'create url (list title)) + (let s (inst 'item 'type 'story 'id (new-item-id) + 'url url 'title title 'text text 'by user 'ip ip) + (save-item s) + (= (items* s!id) s) + (unless (blank url) (register-url s url)) + (push s stories*) + s)) + + +; Bans + +(def ignore (user subject cause) + (set (ignored subject)) + (save-prof subject) + (log-ignore user subject cause)) + +(diskvar ignore-log* (+ newsdir* "ignore-log")) + +(def log-ignore (user subject cause) + (todisk ignore-log* (cons (list subject user cause) ignore-log*))) + +; Kill means stuff with this substring gets killed. Ignore is stronger, +; means that user will be auto-ignored. Eventually this info should +; be stored on disk and not in the source code. + +(disktable banned-ips* (+ newsdir* "banned-ips")) ; was ips +(disktable banned-sites* (+ newsdir* "banned-sites")) ; was sites + +(diskvar comment-kill* (+ newsdir* "comment-kill")) +(diskvar comment-ignore* (+ newsdir* "comment-ignore")) + +(= comment-kill* nil ip-ban-threshold* 3) + +(def set-ip-ban (user ip yesno (o info)) + (= (banned-ips* ip) (and yesno (list user (seconds) info))) + (todisk banned-ips*)) + +(def set-site-ban (user site ban (o info)) + (= (banned-sites* site) (and ban (list ban user (seconds) info))) + (todisk banned-sites*)) + +; Kill submissions from banned ips, but don't auto-ignore users from +; them, because eventually ips will become legit again. + +; Note that ban tests are only applied when a link or comment is +; submitted, not each time it's edited. This will do for now. + +(def story-ban-test (user i ip url) + (site-ban-test user i url) + (ip-ban-test i ip) + (hook 'story-ban-test user i ip url)) + +(def site-ban-test (user i url) + (whenlet ban (banned-sites* (sitename url)) + (if (caris ban 'ignore) (ignore nil user 'site-ban)) + (kill i 'site-ban))) + +(def ip-ban-test (i ip) + (if (banned-ips* ip) (kill i 'banned-ip))) + +(def comment-ban-test (user i ip string kill-list ignore-list) + (when (some [posmatch _ string] ignore-list) + (ignore nil user 'comment-ban)) + (when (or (banned-ips* ip) (some [posmatch _ string] kill-list)) + (kill i 'comment-ban))) + +; An IP is banned when multiple ignored users have submitted over +; ban-threshold* (currently loaded) dead stories from it. + +; Can consider comments too if that later starts to be a problem, +; but the threshold may start to be higher because then you'd be +; dealing with trolls rather than spammers. + +(def maybe-ban-ip (s) + (when (and s!dead (ignored s!by)) + (let bads (loaded-items [and _!dead (astory _) (is _!ip s!ip)]) + (when (and (len> bads ip-ban-threshold*) + (some [and (ignored _!by) (isnt _!by s!by)] bads)) + (set-ip-ban nil s!ip t))))) + +(def killallby (user) + (map [kill _ 'all] (submissions user))) + +; Only called from repl. + +(def kill-whole-thread (c) + (kill c 'thread) + (map kill-whole-thread:item c!kids)) + + +; Polls + +; a way to add a karma threshold for voting in a poll +; or better still an arbitrary test fn, or at least pair of name/threshold. +; option to sort the elements of a poll when displaying +; exclusive field? (means only allow one vote per poll) + +(= poll-threshold* 20) + +(newsop newpoll () + (if (and user (> (karma user) poll-threshold*)) + (newpoll-page user) + (pr "Sorry, you need @poll-threshold* karma to create a poll."))) + +(def newpoll-page (user (o title "Poll: ") (o text "") (o opts "") (o msg)) + (minipage "New Poll" + (pagemessage msg) + (urform user req + (process-poll (get-user req) + (striptags (arg req "t")) + (md-from-form (arg req "x") t) + (striptags (arg req "o")) + req!ip) + (tab + (row "title" (input "t" title 50)) + (row "text" (textarea "x" 4 50 (only.pr text))) + (row "" "Use blank lines to separate choices:") + (row "choices" (textarea "o" 7 50 (only.pr opts))) + (row "" (submit)))))) + +(= fewopts* "A poll must have at least two options.") + +(def process-poll (user title text opts ip) + (if (or (blank title) (blank opts)) + (flink [newpoll-page user title text opts retry*]) + (len> title title-limit*) + (flink [newpoll-page user title text opts toolong*]) + (len< (paras opts) 2) + (flink [newpoll-page user title text opts fewopts*]) + (atlet p (create-poll (multisubst scrubrules* title) text opts user ip) + (ip-ban-test p ip) + (when (ignored user) (kill p 'ignored)) + (submit-item user p) + (maybe-ban-ip p) + "newest"))) + +(def create-poll (title text opts user ip) + (newslog ip user 'create-poll title) + (let p (inst 'item 'type 'poll 'id (new-item-id) + 'title title 'text text 'by user 'ip ip) + (= p!parts (map get!id (map [create-pollopt p nil nil _ user ip] + (paras opts)))) + (save-item p) + (= (items* p!id) p) + (push p stories*) + p)) + +(def create-pollopt (p url title text user ip) + (let o (inst 'item 'type 'pollopt 'id (new-item-id) + 'url url 'title title 'text text 'parent p!id + 'by user 'ip ip) + (save-item o) + (= (items* o!id) o) + o)) + +(def add-pollopt-page (p user) + (minipage "Add Poll Choice" + (urform user req + (do (add-pollopt user p (striptags (arg req "x")) req!ip) + (item-url p!id)) + (tab + (row "text" (textarea "x" 4 50)) + (row "" (submit)))))) + +(def add-pollopt (user p text ip) + (unless (blank text) + (atlet o (create-pollopt p nil nil text user ip) + (++ p!parts (list o!id)) + (save-item p)))) + +(def display-pollopts (p user whence) + (each o (visible user (map item p!parts)) + (display-pollopt nil o user whence) + (spacerow 7))) + +(def display-pollopt (n o user whence) + (tr (display-item-number n) + (tag (td valign 'top) + (votelinks o user whence)) + (tag (td class 'comment) + (tag (div style "margin-top:1px;margin-bottom:0px") + (if (~cansee user o) (pr (pseudo-text o)) + (~live o) (spanclass dead + (pr (if (~blank o!title) o!title o!text))) + (if (and (~blank o!title) (~blank o!url)) + (link o!title o!url) + (fontcolor black (pr o!text))))))) + (tr (if n (td)) + (td) + (tag (td class 'default) + (spanclass comhead + (itemscore o) + (editlink o user) + (killlink o user whence) + (deletelink o user whence) + (deadmark o user))))) + + +; Individual Item Page (= Comments Page of Stories) + +(defmemo item-url (id) (+ "item?id=" id)) + +(newsop item (id) + (let s (safe-item id) + (if (news-type s) + (do (if s!deleted (note-baditem user ip)) + (item-page user s)) + (do (note-baditem user ip) + (pr "No such item."))))) + +(= baditemreqs* (table) baditem-threshold* 1/100) + +; Something looking at a lot of deleted items is probably the bad sort +; of crawler. Throttle it for this server invocation. + +(def note-baditem (user ip) + (unless (admin user) + (++ (baditemreqs* ip 0)) + (with (r (requests/ip* ip) b (baditemreqs* ip)) + (when (and (> r 500) (> (/ b r) baditem-threshold*)) + (set (throttle-ips* ip)))))) + +; redefined later + +(def news-type (i) (and i (in i!type 'story 'comment 'poll 'pollopt))) + +(def item-page (user i) + (with (title (and (cansee user i) + (or i!title (aand i!text (ellipsize (striptags it))))) + here (item-url i!id)) + (longpage user (msec) nil nil title here + (tab (display-item nil i user here) + (display-item-text i user) + (when (apoll i) + (spacerow 10) + (tr (td) + (td (tab (display-pollopts i user here))))) + (when (and (cansee user i) (comments-active i)) + (spacerow 10) + (row "" (comment-form i user here)))) + (br2) + (when (and i!kids (commentable i)) + (tab (display-subcomments i user here)) + (br2))))) + +(def commentable (i) (in i!type 'story 'comment 'poll)) + +; By default the ability to comment on an item is turned off after +; 45 days, but this can be overriden with commentable key. + +(= commentable-threshold* (* 60 24 45)) + +(def comments-active (i) + (and (live&commentable i) + (live (superparent i)) + (or (< (item-age i) commentable-threshold*) + (mem 'commentable i!keys)))) + + +(= displayfn* (table)) + +(= (displayfn* 'story) (fn (n i user here inlist) + (display-story n i user here))) + +(= (displayfn* 'comment) (fn (n i user here inlist) + (display-comment n i user here nil 0 nil inlist))) + +(= (displayfn* 'poll) (displayfn* 'story)) + +(= (displayfn* 'pollopt) (fn (n i user here inlist) + (display-pollopt n i user here))) + +(def display-item (n i user here (o inlist)) + ((displayfn* (i 'type)) n i user here inlist)) + +(def superparent (i) + (aif i!parent (superparent:item it) i)) + +(def display-item-text (s user) + (when (and (cansee user s) + (in s!type 'story 'poll) + (blank s!url) + (~blank s!text)) + (spacerow 2) + (row "" s!text))) + + +; Edit Item + +(def edit-url (i) (+ "edit?id=" i!id)) + +(newsop edit (id) + (let i (safe-item id) + (if (and i + (cansee user i) + (editable-type i) + (or (news-type i) (admin user) (author user i))) + (edit-page user i) + (pr "No such item.")))) + +(def editable-type (i) (fieldfn* i!type)) + +(= fieldfn* (table)) + +(= (fieldfn* 'story) + (fn (user s) + (with (a (admin user) e (editor user) x (canedit user s)) + `((string1 title ,s!title t ,x) + (url url ,s!url t ,e) + (mdtext2 text ,s!text t ,x) + ,@(standard-item-fields s a e x))))) + +(= (fieldfn* 'comment) + (fn (user c) + (with (a (admin user) e (editor user) x (canedit user c)) + `((mdtext text ,c!text t ,x) + ,@(standard-item-fields c a e x))))) + +(= (fieldfn* 'poll) + (fn (user p) + (with (a (admin user) e (editor user) x (canedit user p)) + `((string1 title ,p!title t ,x) + (mdtext2 text ,p!text t ,x) + ,@(standard-item-fields p a e x))))) + +(= (fieldfn* 'pollopt) + (fn (user p) + (with (a (admin user) e (editor user) x (canedit user p)) + `((string title ,p!title t ,x) + (url url ,p!url t ,x) + (mdtext2 text ,p!text t ,x) + ,@(standard-item-fields p a e x))))) + +(def standard-item-fields (i a e x) + `((int votes ,(len i!votes) ,a nil) + (int score ,i!score t ,a) + (int sockvotes ,i!sockvotes ,a ,a) + (yesno dead ,i!dead ,e ,e) + (yesno deleted ,i!deleted ,a ,a) + (sexpr flags ,i!flags ,a nil) + (sexpr keys ,i!keys ,a ,a) + (string ip ,i!ip ,e nil))) + +; Should check valid-url etc here too. In fact make a fn that +; does everything that has to happen after submitting a story, +; and call it both there and here. + +(def edit-page (user i) + (let here (edit-url i) + (shortpage user nil nil "Edit" here + (tab (display-item nil i user here) + (display-item-text i user)) + (br2) + (vars-form user + ((fieldfn* i!type) user i) + (fn (name val) + (unless (ignore-edit user i name val) + (when (and (is name 'dead) val (no i!dead)) + (log-kill i user)) + (= (i name) val))) + (fn () (if (admin user) (pushnew 'locked i!keys)) + (save-item i) + (metastory&adjust-rank i) + (wipe (comment-cache* i!id)) + (edit-page user i))) + (hook 'edit user i)))) + +(def ignore-edit (user i name val) + (case name title (len> val title-limit*) + dead (and (mem 'nokill i!keys) (~admin user)))) + + +; Comment Submission + +(def comment-login-warning (parent whence (o text)) + (login-page 'both "You have to be logged in to comment." + (fn (u ip) + (ensure-news-user u) + (newslog ip u 'comment-login) + (addcomment-page parent u whence text)))) + +(def addcomment-page (parent user whence (o text) (o msg)) + (minipage "Add Comment" + (pagemessage msg) + (tab + (let here (flink [addcomment-page parent (get-user _) whence text msg]) + (display-item nil parent user here)) + (spacerow 10) + (row "" (comment-form parent user whence text))))) + +(= noob-comment-msg* nil) + +; Comment forms last for 30 min (- cache time) + +(def comment-form (parent user whence (o text)) + (tarform 1800 + (fn (req) + (when-umatch/r user req + (process-comment user parent (arg req "text") req!ip whence))) + (textarea "text" 6 60 + (aif text (prn (unmarkdown it)))) + (when (and noob-comment-msg* (noob user)) + (br2) + (spanclass subtext (pr noob-comment-msg*))) + (br2) + (submit (if (acomment parent) "reply" "add comment")))) + +(= comment-threshold* -20) + +; Have to remove #\returns because a form gives you back "a\r\nb" +; instead of just "a\nb". Maybe should just remove returns from +; the vals coming in from any form, e.g. in aform. + +(def process-comment (user parent text ip whence) + (if (no user) + (flink [comment-login-warning parent whence text]) + (empty text) + (flink [addcomment-page parent (get-user _) whence text retry*]) + (oversubmitting user ip 'comment) + (flink [msgpage user toofast*]) + (atlet c (create-comment parent (md-from-form text) user ip) + (comment-ban-test user c ip text comment-kill* comment-ignore*) + (if (bad-user user) (kill c 'ignored/karma)) + (submit-item user c) + whence))) + +(def bad-user (u) + (or (ignored u) (< (karma u) comment-threshold*))) + +(def create-comment (parent text user ip) + (newslog ip user 'comment (parent 'id)) + (let c (inst 'item 'type 'comment 'id (new-item-id) + 'text text 'parent parent!id 'by user 'ip ip) + (save-item c) + (= (items* c!id) c) + (push c!id parent!kids) + (save-item parent) + (push c comments*) + c)) + + +; Comment Display + +(def display-comment-tree (c user whence (o indent 0) (o initialpar)) + (when (cansee-descendant user c) + (display-1comment c user whence indent initialpar) + (display-subcomments c user whence (+ indent 1)))) + +(def display-1comment (c user whence indent showpar) + (row (tab (display-comment nil c user whence t indent showpar showpar)))) + +(def display-subcomments (c user whence (o indent 0)) + (each k (sort (compare > frontpage-rank:item) c!kids) + (display-comment-tree (item k) user whence indent))) + +(def display-comment (n c user whence (o astree) (o indent 0) + (o showpar) (o showon)) + (tr (display-item-number n) + (when astree (td (hspace (* indent 40)))) + (tag (td valign 'top) (votelinks c user whence t)) + (display-comment-body c user whence astree indent showpar showon))) + +; Comment caching doesn't make generation of comments significantly +; faster, but may speed up everything else by generating less garbage. + +; It might solve the same problem more generally to make html code +; more efficient. + +(= comment-cache* (table) comment-cache-timeout* (table) cc-window* 10000) + +(= comments-printed* 0 cc-hits* 0) + +(= comment-caching* t) + +; Cache comments generated for nil user that are over an hour old. +; Only try to cache most recent 10k items. But this window moves, +; so if server is running a long time could have more than that in +; cache. Probably should actively gc expired cache entries. + +(def display-comment-body (c user whence astree indent showpar showon) + (++ comments-printed*) + (if (and comment-caching* + astree (no showpar) (no showon) + (live c) + (nor (admin user) (editor user) (author user c)) + (< (- maxid* c!id) cc-window*) + (> (- (seconds) c!time) 60)) ; was 3600 + (pr (cached-comment-body c user whence indent)) + (gen-comment-body c user whence astree indent showpar showon))) + +(def cached-comment-body (c user whence indent) + (or (and (> (or (comment-cache-timeout* c!id) 0) (seconds)) + (awhen (comment-cache* c!id) + (++ cc-hits*) + it)) + (= (comment-cache-timeout* c!id) + (cc-timeout c!time) + (comment-cache* c!id) + (tostring (gen-comment-body c user whence t indent nil nil))))) + +; Cache for the remainder of the current minute, hour, or day. + +(def cc-timeout (t0) + (let age (- (seconds) t0) + (+ t0 (if (< age 3600) + (* (+ (trunc (/ age 60)) 1) 60) + (< age 86400) + (* (+ (trunc (/ age 3600)) 1) 3600) + (* (+ (trunc (/ age 86400)) 1) 86400))))) + +(def gen-comment-body (c user whence astree indent showpar showon) + (tag (td class 'default) + (let parent (and (or (no astree) showpar) (c 'parent)) + (tag (div style "margin-top:2px; margin-bottom:-10px; ") + (spanclass comhead + (itemline c user) + (permalink c user) + (when parent + (when (cansee user c) (pr bar*)) + (link "parent" (item-url ((item parent) 'id)))) + (editlink c user) + (killlink c user whence) + (blastlink c user whence) + (deletelink c user whence) + ; a hack to check whence but otherwise need an arg just for this + (unless (or astree (is whence "newcomments")) + (flaglink c user whence)) + (deadmark c user) + (when showon + (pr " | on: ") + (let s (superparent c) + (link (ellipsize s!title 50) (item-url s!id)))))) + (when (or parent (cansee user c)) + (br)) + (spanclass comment + (if (~cansee user c) (pr (pseudo-text c)) + (nor (live c) (author user c)) (spanclass dead (pr c!text)) + (fontcolor (comment-color c) + (pr c!text)))) + (when (and astree (cansee user c) (live c)) + (para) + (tag (font size 1) + (if (and (~mem 'neutered c!keys) + (replyable c indent) + (comments-active c)) + (underline (replylink c whence)) + (fontcolor sand (pr "-----")))))))) + +; For really deeply nested comments, caching could add another reply +; delay, but that's ok. + +; People could beat this by going to the link url or manually entering +; the reply url, but deal with that if they do. + +(= reply-decay* 1.8) ; delays: (0 0 1 3 7 12 18 25 33 42 52 63) + +(def replyable (c indent) + (or (< indent 2) + (> (item-age c) (expt (- indent 1) reply-decay*)))) + +(def replylink (i whence (o title 'reply)) + (link title (+ "reply?id=" i!id "&whence=" (urlencode whence)))) + +(newsop reply (id whence) + (with (i (safe-item id) + whence (or (only.urldecode whence) "news")) + (if (only.comments-active i) + (if user + (addcomment-page i user whence) + (login-page 'both "You have to be logged in to comment." + (fn (u ip) + (ensure-news-user u) + (newslog ip u 'comment-login) + (addcomment-page i u whence)))) + (pr "No such item.")))) + +(def comment-color (c) + (if (> c!score 0) black (grayrange c!score))) + +(defmemo grayrange (s) + (gray (min 230 (round (expt (* (+ (abs s) 2) 900) .6))))) + + +; Threads + +(def threads-url (user) (+ "threads?id=" user)) + +(newsop threads (id) + (if id + (threads-page user id) + (pr "No user specified."))) + +(def threads-page (user subject) + (if (profile subject) + (withs (title (+ subject "'s comments") + label (if (is user subject) "threads" title) + here (threads-url subject)) + (longpage user (msec) nil label title here + (awhen (keep [and (cansee user _) (~subcomment _)] + (comments subject maxend*)) + (display-threads user it label title here)))) + (prn "No such user."))) + +(def display-threads (user comments label title whence + (o start 0) (o end threads-perpage*)) + (tab + (each c (cut comments start end) + (display-comment-tree c user whence 0 t)) + (when end + (let newend (+ end threads-perpage*) + (when (and (<= newend maxend*) (< end (len comments))) + (spacerow 10) + (row (tab (tr (td (hspace 0)) + (td (hspace votewid*)) + (tag (td class 'title) + (morelink display-threads + comments label title end newend)))))))))) + +(def submissions (user (o limit)) + (map item (firstn limit (uvar user submitted)))) + +(def comments (user (o limit)) + (map item (retrieve limit acomment:item (uvar user submitted)))) + +(def subcomment (c) + (some [and (acomment _) (is _!by c!by) (no _!deleted)] + (ancestors c))) + +(def ancestors (i) + (accum a (trav i!parent a:item self:!parent:item))) + + +; Submitted + +(def submitted-url (user) (+ "submitted?id=" user)) + +(newsop submitted (id) + (if id + (submitted-page user id) + (pr "No user specified."))) + +(def submitted-page (user subject) + (if (profile subject) + (with (label (+ subject "'s submissions") + here (submitted-url subject)) + (longpage user (msec) nil label label here + (if (or (no (ignored subject)) + (is user subject) + (seesdead user)) + (aif (keep [and (metastory _) (cansee user _)] + (submissions subject)) + (display-items user it label label here 0 perpage* t))))) + (pr "No such user."))) + + +; RSS + +(newsop rss () (rsspage nil)) + +(newscache rsspage user 90 + (rss-stories (retrieve perpage* live ranked-stories*))) + +(def rss-stories (stories) + (tag (rss version "2.0") + (tag channel + (tag title (pr this-site*)) + (tag link (pr site-url*)) + (tag description (pr site-desc*)) + (each s stories + (tag item + (let comurl (+ site-url* (item-url s!id)) + (tag title (pr (eschtml s!title))) + (tag link (pr (if (blank s!url) comurl (eschtml s!url)))) + (tag comments (pr comurl)) + (tag description + (cdata (link "Comments" comurl))))))))) + + +; User Stats + +(newsop leaders () (leaderspage user)) + +(= nleaders* 20) + +(newscache leaderspage user 1000 + (longpage user (msec) nil "leaders" "Leaders" "leaders" + (sptab + (let i 0 + (each u (firstn nleaders* (leading-users)) + (tr (tdr:pr (++ i) ".") + (td (userlink user u nil)) + (tdr:pr (karma u)) + (when (admin user) + (tdr:prt (only.num (uvar u avg) 2 t t)))) + (if (is i 10) (spacerow 30))))))) + +(= leader-threshold* 1) ; redefined later + +(def leading-users () + (sort (compare > [karma _]) + (users [and (> (karma _) leader-threshold*) (~admin _)]))) + +(adop editors () + (tab (each u (users [is (uvar _ auth) 1]) + (row (userlink user u))))) + + +(= update-avg-threshold* 0) ; redefined later + +(defbg update-avg 45 + (unless (or (empty profs*) (no stories*)) + (update-avg (rand-user [and (only.> (car (uvar _ submitted)) + (- maxid* initload*)) + (len> (uvar _ submitted) + update-avg-threshold*)])))) + +(def update-avg (user) + (= (uvar user avg) (comment-score user)) + (save-prof user)) + +(def rand-user ((o test idfn)) + (evtil (rand-key profs*) test)) + +; Ignore the most recent 5 comments since they may still be gaining votes. +; Also ignore the highest-scoring comment, since possibly a fluff outlier. + +(def comment-score (user) + (aif (check (nthcdr 5 (comments user 50)) [len> _ 10]) + (avg (cdr (sort > (map !score (rem !deleted it))))) + nil)) + + +; Comment Analysis + +; Instead of a separate active op, should probably display this info +; implicitly by e.g. changing color of commentlink or by showing the +; no of comments since that user last looked. + +(newsop active () (active-page user)) + +(newscache active-page user 600 + (listpage user (msec) (actives user) "active" "Active Threads")) + +(def actives (user (o n maxend*) (o consider 2000)) + (visible user (rank-stories n consider (memo active-rank)))) + +(= active-threshold* 1500) + +(def active-rank (s) + (sum [max 0 (- active-threshold* (item-age _))] + (cdr (family s)))) + +(def family (i) (cons i (mappend family:item i!kids))) + + +(newsop newcomments () (newcomments-page user)) + +(newscache newcomments-page user 60 + (listpage user (msec) (visible user (firstn maxend* comments*)) + "comments" "New Comments" "newcomments" nil)) + + +; Doc + +(defop formatdoc req + (msgpage (get-user req) formatdoc* "Formatting Options")) + +(= formatdoc-url* "formatdoc") + +(= formatdoc* +"Blank lines separate paragraphs. +

Text after a blank line that is indented by two or more spaces is +reproduced verbatim. (This is intended for code.) +

Text surrounded by asterisks is italicized, if the character after the +first asterisk isn't whitespace. +

Urls become links, except in the text field of a submission.

") + + +; Noprocrast + +(def check-procrast (user) + (or (no user) + (no (uvar user noprocrast)) + (let now (seconds) + (unless (uvar user firstview) + (reset-procrast user)) + (or (when (< (/ (- now (uvar user firstview)) 60) + (uvar user maxvisit)) + (= (uvar user lastview) now) + (save-prof user) + t) + (when (> (/ (- now (uvar user lastview)) 60) + (uvar user minaway)) + (reset-procrast user) + t))))) + +(def reset-procrast (user) + (= (uvar user lastview) (= (uvar user firstview) (seconds))) + (save-prof user)) + +(def procrast-msg (user whence) + (let m (+ 1 (trunc (- (uvar user minaway) + (minutes-since (uvar user lastview))))) + (pr "Get back to work!") + (para "Sorry, you can't see this page. Based on the anti-procrastination + parameters you set in your profile, you'll be able to use the site + again in " (plural m "minute") ".") + (para "(If you got this message after submitting something, don't worry, + the submission was processed.)") + (para "To change your anti-procrastination settings, go to your profile + by clicking on your username. If noprocrast is set to + yes, you'll be limited to sessions of maxvisit + minutes, with minaway minutes between them.") + (para) + (w/rlink whence (underline (pr "retry"))) + ; (hspace 20) + ; (w/rlink (do (reset-procrast user) whence) (underline (pr "override"))) + (br2))) + + +; Reset PW + +(defopg resetpw req (resetpw-page (get-user req))) + +(def resetpw-page (user (o msg)) + (minipage "Reset Password" + (if msg + (pr msg) + (blank (uvar user email)) + (do (pr "Before you do this, please add your email address to your ") + (underlink "profile" (user-url user)) + (pr ". Otherwise you could lose your account if you mistype + your new password."))) + (br2) + (uform user req (try-resetpw user (arg req "p")) + (single-input "New password: " 'p 20 "reset" t)))) + +(def try-resetpw (user newpw) + (if (len< newpw 4) + (resetpw-page user "Passwords should be a least 4 characters long. + Please choose another.") + (do (set-pw user newpw) + (newspage user)))) + + +; Scrubrules + +(defopa scrubrules req + (scrub-page (get-user req) scrubrules*)) + +; If have other global alists, generalize an alist edit page. +; Or better still generalize vars-form. + +(def scrub-page (user rules (o msg nil)) + (minipage "Scrubrules" + (when msg (pr msg) (br2)) + (uform user req + (with (froms (lines (arg req "from")) + tos (lines (arg req "to"))) + (if (is (len froms) (len tos)) + (do (todisk scrubrules* (map list froms tos)) + (scrub-page user scrubrules* "Changes saved.")) + (scrub-page user rules "To and from should be same length."))) + (pr "From: ") + (tag (textarea name 'from + cols (apply max 20 (map len (map car rules))) + rows (+ (len rules) 3)) + (apply pr #\newline (intersperse #\newline (map car rules)))) + (pr " To: ") + (tag (textarea name 'to + cols (apply max 20 (map len (map cadr rules))) + rows (+ (len rules) 3)) + (apply pr #\newline (intersperse #\newline (map cadr rules)))) + (br2) + (submit "update")))) + + +; Abuse Analysis + +(adop badsites () + (sptab + (row "Dead" "Days" "Site" "O" "K" "I" "Users") + (each (site deads) (with (banned (banned-site-items) + pairs (killedsites)) + (+ pairs (map [list _ (banned _)] + (rem (fn (d) + (some [caris _ d] pairs)) + (keys banned-sites*))))) + (let ban (car (banned-sites* site)) + (tr (tdr (when deads + (onlink (len deads) + (listpage user (msec) deads + nil (+ "killed at " site) "badsites")))) + (tdr (when deads (pr (round (days-since ((car deads) 'time)))))) + (td site) + (td (w/rlink (do (set-site-ban user site nil) "badsites") + (fontcolor (if ban gray.220 black) (pr "x")))) + (td (w/rlink (do (set-site-ban user site 'kill) "badsites") + (fontcolor (case ban kill darkred gray.220) (pr "x")))) + (td (w/rlink (do (set-site-ban user site 'ignore) "badsites") + (fontcolor (case ban ignore darkred gray.220) (pr "x")))) + (td (each u (dedup (map !by deads)) + (userlink user u nil) + (pr " ")))))))) + +(defcache killedsites 300 + (let bads (table [each-loaded-item i + (awhen (and i!dead (sitename i!url)) + (push i (_ it)))]) + (with (acc nil deadcount (table)) + (each (site items) bads + (let n (len items) + (when (> n 2) + (= (deadcount site) n) + (insort (compare > deadcount:car) + (list site (rev items)) + acc)))) + acc))) + +(defcache banned-site-items 300 + (table [each-loaded-item i + (awhen (and i!dead (check (sitename i!url) banned-sites*)) + (push i (_ it)))])) + +; Would be nice to auto unban ips whose most recent submission is > n +; days old, but hard to do because of lazy loading. Would have to keep +; a table of most recent submission per ip, and only enforce bannnedness +; if < n days ago. + +(adop badips () + (withs ((bads goods) (badips) + (subs ips) (sorted-badips bads goods)) + (sptab + (row "IP" "Days" "Dead" "Live" "Users") + (each ip ips + (tr (td (let banned (banned-ips* ip) + (w/rlink (do (set-ip-ban user ip (no banned)) + "badips") + (fontcolor (if banned darkred) (pr ip))))) + (tdr (when (or (goods ip) (bads ip)) + (pr (round (days-since + (max (aif (car (goods ip)) it!time 0) + (aif (car (bads ip)) it!time 0))))))) + (tdr (onlink (len (bads ip)) + (listpage user (msec) (bads ip) + nil (+ "dead from " ip) "badips"))) + (tdr (onlink (len (goods ip)) + (listpage user (msec) (goods ip) + nil (+ "live from " ip) "badips"))) + (td (each u (subs ip) + (userlink user u nil) + (pr " ")))))))) + +(defcache badips 300 + (with (bads (table) goods (table)) + (each-loaded-item s + (if (and s!dead (commentable s)) + (push s (bads s!ip)) + (push s (goods s!ip)))) + (each (k v) bads (zap rev (bads k))) + (each (k v) goods (zap rev (goods k))) + (list bads goods))) + +(def sorted-badips (bads goods) + (withs (ips (let ips (rem [len< (bads _) 2] (keys bads)) + (+ ips (rem [mem _ ips] (keys banned-ips*)))) + subs (table + [each ip ips + (= (_ ip) (dedup (map !by (+ (bads ip) (goods ip)))))])) + (list subs + (sort (compare > (memo [badness (subs _) (bads _) (goods _)])) + ips)))) + +(def badness (subs bads goods) + (* (/ (len bads) + (max .9 (expt (len goods) 2)) + (expt (+ (days-since (aif (car bads) it!time 0)) + 1) + 2)) + (if (len> subs 1) 20 1))) + + +(edop flagged () + (display-selected-items user [retrieve maxend* flagged _] "flagged")) + +(def flagged (i) + (and (live i) + (~mem 'nokill i!keys) + (len> i!flags many-flags*))) + + +(edop killed () + (display-selected-items user [retrieve maxend* !dead _] "killed")) + +(def display-selected-items (user f whence) + (display-items user (f stories*) nil nil whence) + (vspace 35) + (color-stripe textgray) + (vspace 35) + (display-items user (f comments*) nil nil whence)) + + +; Rather useless thus; should add more data. + +(adop badguys () + (tab (each u (sort (compare > [uvar _ created]) + (users [ignored _])) + (row (userlink user u nil))))) + +(adop badlogins () (logins-page bad-logins*)) + +(adop goodlogins () (logins-page good-logins*)) + +(def logins-page (source) + (sptab (each (time ip user) (firstn 100 (rev (qlist source))) + (row time ip user)))) + + +; Stats + +(adop optimes () + (sptab + (tr (td "op") (tdr "avg") (tdr "med") (tdr "req") (tdr "total")) + (spacerow 10) + (each name (sort < newsop-names*) + (tr (td name) + (let ms (only.avg (qlist (optimes* name))) + (tdr:prt (only.round ms)) + (tdr:prt (only.med (qlist (optimes* name)))) + (let n (opcounts* name) + (tdr:prt n) + (tdr:prt (and n (round (/ (* n ms) 1000)))))))))) + +(defop topcolors req + (minipage "Custom Colors" + (tab + (each c (dedup (map downcase (trues [uvar _ topcolor] (users)))) + (tr (td c) (tdcolor (hex>color c) (hspace 30))))))) + + diff --git a/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))))) + diff --git a/srv.arc b/srv.arc new file mode 100644 index 0000000..65db716 --- /dev/null +++ b/srv.arc @@ -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 new file mode 100644 index 0000000..100407f Binary files /dev/null and b/static/arc.png differ diff --git a/static/grayarrow.gif b/static/grayarrow.gif new file mode 100644 index 0000000..888485f Binary files /dev/null and b/static/grayarrow.gif differ diff --git a/static/graydown.gif b/static/graydown.gif new file mode 100644 index 0000000..0ea7777 Binary files /dev/null and b/static/graydown.gif differ diff --git a/static/robots.txt b/static/robots.txt new file mode 100644 index 0000000..e69de29 diff --git a/static/s.gif b/static/s.gif new file mode 100644 index 0000000..1d11fa9 Binary files /dev/null and b/static/s.gif differ 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 -- cgit v1.2.3