@@ -1,50 +1,11 @@ -; scheme48 -; ,open tables sockets extended-ports c-system-function ascii i/o-internal -; ,open posix-files handle random pp simple-conditions - -; to do: -; select, perhaps with threads, or pltt events -; check argument count for complex arguments - -; refs.arc, first 300 lines of x, total CPU time including startup. on powerbook. -; scheme48: 31.944u 0.518s 2:13.65 24.2% 0+0k 5+7io 0pf+0w -; mzscheme: 16.425u 0.489s 0:52.61 32.1% 0+0k 26+22io 0pf+0w - -; dynamic creation of local variables with = -; can you create globals inside a procedure? -; does action of = depend on whether, at run time, -; the variable has a global definition? -; what's the scope of such a variable? -; though a.lisp seems to create a global, not a local! -; run-time expansion of macros -; how do I know if something is a macro at compile time? -; macros have lexical scope. so how do i know if a lexical -; variable is going to be bound to a procedure? or to a macro? -; what is annotate doing to symbols? -; tests.arc implies that '(a b) produces a mutable list -; so (fn () '(a)) produces a list that can be modified, -; and future calls will reflect the modifications -; oy. clisp works this way too. -; it's not that easy to simulate this. -; what is this? (def foo1 (x (o y x)) (list x y)) - -; it's not clear I translate NILs in the outputs of macros correctly. -; I translate (NIL . NIL) to ('NIL . '()) -; I use Scheme apply to call macros. -; Scheme apply demands a '()-terminated list. -; most macros have a . body argument. -; so body is '()-terminated, not NIL-terminated. -; solution: ar-false? knows about '() -; this doesn't work, since var isn't a variable name: -; (mac or args -; (and args -; (let var (tag 'symbol (list 'or)) -; (list 'let var (car args) -; (list 'if var var (cons 'or (cdr args))))))) +; Arc Compiler (module ac mzscheme (provide (all-defined)) +; uncomment the following require for mzscheme-4.x +; much of Arc will work, but not mutable cons pairs. +; (require rnrs/mutable-pairs-6) (require (lib "port.ss")) (require (lib "process.ss")) (require (lib "pretty.ss")) @@ -65,9 +26,11 @@ ((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) 'set) (ac-set (cdr s) env)) - ; this line could be removed without changing semantics + ((eq? (xcar s) 'assign) (ac-set (cdr s) env)) + ; the next two clauses could be removed without changing semantics ((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)) ((pair? s) (ac-call (car s) (cdr s) env)) (#t (err "Bad object in expression" s)))) @@ -80,14 +43,15 @@ (define (ssyntax? x) (and (symbol? x) - (not (or (eqv? x '+) (eqv? 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 #\!))) + (or (eqv? c #\:) (eqv? c #\~) ;(eqv? c #\_) + (eqv? c #\.) (eqv? c #\!))) (has-ssyntax-char? string (- i 1))))) (define (read-from-string str) @@ -96,8 +60,13 @@ (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. + (define (expand-ssyntax sym) ((cond ((or (insym? #\: sym) (insym? #\~ sym)) expand-compose) + ; ((insym? #\_ sym) expand-curry) ((or (insym? #\. sym) (insym? #\! sym)) expand-sexpr) (#t (error "Unknown ssyntax" sym))) sym)) @@ -118,28 +87,64 @@ (car elts) (cons 'compose elts)))) -(define (expand-sexpr sym) - (build-sexpr (tokens (lambda (c) (or (eqv? c #\.) (eqv? c #\!))) - (symbol->chars sym) - '() - '() - #t))) - -; no error-checking! - -(define (build-sexpr toks) - (cond ((null? toks) +; 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 toks) #\.) - (cons (chars->value (cadr toks)) - (build-sexpr (cddr toks)))) - ((eqv? (car toks) #\!) - (cons (list 'quote (chars->value (cadr toks))) - (build-sexpr (cddr toks)))) + ((eqv? (car elts) #\_) + (cons (string->symbol (string-append "v" (number->string n))) + (exc (cdr elts) (+ n 1)))) (#t - (cons (chars->value (car toks)) - (build-sexpr (cdr toks)))))) - + (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))) @@ -147,17 +152,18 @@ (define (chars->value chars) (read-from-string (list->string chars))) -; result will contain || if separator at end of symbol; could use -; that to mean something - (define (tokens test source token acc keepsep?) (cond ((null? source) - (reverse (cons (reverse token) acc))) + (reverse (if (pair? token) + (cons (reverse token) acc) + acc))) ((test (car source)) (tokens test (cdr source) '() - (let ((rec (cons (reverse token) acc))) + (let ((rec (if (null? token) + acc + (cons (reverse token) acc)))) (if keepsep? (cons (car source) rec) rec)) @@ -178,7 +184,6 @@ ((null? (cdr fns)) (cons (car fns) args)) (#t (list (car fns) (decompose (cdr fns) args))))) - (define (ac-global-name s) (string->symbol (string-append "_" (symbol->string s)))) @@ -195,6 +200,7 @@ ; 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)) @@ -219,21 +225,33 @@ (cond ((null? args) ''nil) ((null? (cdr args)) (ac (car args) env)) (#t `(if (not (ar-false? ,(ac (car args) env))) -;(not (eq? 'nil ,(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) - `(lambda ,(let ((a (ac-denil args))) (if (eqv? a 'nil) '() a)) - 'nil - ,@(ac-body body (append (ac-arglist args) 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) @@ -246,13 +264,13 @@ ; 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 - 'nil - ,@(ac-body body (append (ac-complex-getargs z) env)))))) + ,@(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. @@ -260,6 +278,7 @@ ; 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))) @@ -287,15 +306,18 @@ ; (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)) @@ -303,9 +325,14 @@ (#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) - '() - (cons (ac (car body) env) (ac-body (cdr body) env)))) + (list (list 'quote 'nil)) + (ac-body body env))) ; (set v1 expr1 v2 expr2 ...) @@ -315,36 +342,82 @@ (define (ac-setn x env) (if (null? x) '() - (cons (ac-set1 (ac-macex (car x)) (ac (cadr x) env) env) + (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 b env) +(define (ac-set1 a b1 env) (if (symbol? a) - (let ((name (string->symbol (string-append " " (symbol->string a))))) - (list 'let `((,name ,b)) + (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 ,name)) + ((lex? a env) `(set! ,a zz)) (#t `(namespace-set-variable-value! ',(ac-global-name a) - ,name))) - name)) + 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 (ar-xcdr 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) ,@(map (lambda (x) (ac x env)) args))) + `(,(ac fn env) ,@(ac-args (cadr fn) args env))) + ((and (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) @@ -412,6 +485,7 @@ (ac-denil x))) ; is v lexically bound? + (define (lex? v env) (memq v env)) @@ -420,24 +494,38 @@ ; #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))) -;(define (err msg . args) -; (display msg) -; (map (lambda (a) (display " ") (write a)) args) -; (newline) -; (xxundefined)) - -(define err error) ; eli says need to remove xxundefined for speed +(define err error) ; run-time primitive procedures -(define (xdef a b) - (namespace-set-variable-value! (ac-global-name a) b) - b) +;(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)) @@ -449,7 +537,7 @@ (hash-table-put! fn-signatures a (list parms)) b) -(xdef 'sig fn-signatures) +(xdef sig fn-signatures) ; versions of car and cdr for parsing arguments for optional ; parameters, that yield nil for nil. maybe we should use @@ -479,32 +567,42 @@ (define (ar-false? x) (or (eq? x 'nil) (eq? x '()) (eq? x #f))) -#| - (if (eq? x 'nil) #t - (if (eq? x '()) #t - (not x))) -|# - ; call a function or perform an array ref, hash ref, &c -; Non-fn donstants in functional position are valuable real estate, so -; should figure out the best way to exploit it. +; 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) #f))) + (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) +(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) @@ -550,44 +648,52 @@ ((null? (cdr args)) (ar-nil-terminate (car args))) (#t (cons (car args) (ar-apply-args (cdr args)))))) -(xdef 'cons cons) +(xdef cons cons) -(xdef 'car (lambda (x) +(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) +(xdef cdr (lambda (x) (cond ((pair? x) (cdr x)) ((eqv? x 'nil) 'nil) ((eqv? x '()) 'nil) (#t (err "Can't take cdr of" x))))) -; reduce? +(define (tnil x) (if x 't 'nil)) -(define (pairwise pred args base) - (let ((n (length args))) - (cond ((< n 2) base) - ((= n 2) (apply pred args)) - (#t (and (pred (car args) (cadr args)) - (pairwise pred (cdr args) base)))))) +; (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 (tnil x) (if x 't 'nil)) +(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? -(xdef 'is (lambda args - (tnil (or (all (lambda (a) (eqv? (car args) a)) (cdr args)) - (and (all string? args) - (apply string=? args)) - (all ar-false? args))))) +; 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))))) -(xdef 'err err) -(xdef 'nil 'nil) -(xdef 't 't) +; 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) @@ -599,7 +705,7 @@ ; problem with generic +: what to return when no args? ; could even coerce based on type of first arg... -(xdef '+ (lambda args +(xdef + (lambda args (cond ((null? args) 0) ((all string? args) (apply string-append args)) @@ -607,42 +713,43 @@ (ac-niltree (apply append (map ar-nil-terminate args)))) (#t (apply + args))))) -(xdef '- -) -(xdef '* *) -(xdef '/ /) -(xdef 'mod modulo) -(xdef 'expt expt) -(xdef 'sqrt sqrt) +(define (ar-+2 x y) + (cond ((and (string? x) (string? y)) + (string-append x y)) + ((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 (arc> . args) - (cond ((all number? args) (apply > args)) - ((all string? args) (pairwise string>? args #f)) - ((all symbol? args) (pairwise (lambda (x y) - (string>? (symbol->string x) - (symbol->string y))) - args - #f)) - ((all char? args) (pairwise char>? args #f)) - (#t (apply > args)))) - -(xdef '> (lambda args (tnil (apply arc> args)))) - -(define (arc< . args) - (cond ((all number? args) (apply < args)) - ((all string? args) (pairwise string<? args #f)) - ((all symbol? args) (pairwise (lambda (x y) - (string<? (symbol->string x) - (symbol->string y))) - args - #f)) - ((all char? args) (pairwise char<? args #f)) - (#t (apply < args)))) - -(xdef '< (lambda args (tnil (apply arc< args)))) - -(xdef 'len (lambda (x) +(define (ar->2 x y) + (tnil (cond ((and (number? x) (number? y)) (> x y)) + ((and (string? x) (string? y)) (string>? x y)) + ((and (symbol? x) (symbol? y)) (string>? (symbol->string x) + (symbol->string y))) + ((and (char? x) (char? y)) (char>? x y)) + (#t (> x y))))) + +(xdef > (lambda args (pairwise ar->2 args))) + +(define (ar-<2 x y) + (tnil (cond ((and (number? x) (number? y)) (< x y)) + ((and (string? x) (string? y)) (string<? x y)) + ((and (symbol? x) (symbol? y)) (string<? (symbol->string x) + (symbol->string y))) + ((and (char? x) (char? y)) (char<? x y)) + (#t (< x y))))) + +(xdef < (lambda args (pairwise ar-<2 args))) + +(xdef len (lambda (x) (cond ((string? x) (string-length x)) ((hash-table? x) (hash-table-count x)) (#t (length (ar-nil-terminate x)))))) @@ -654,7 +761,7 @@ (cond ((eqv? (ar-type rep) type) rep) (#t (vector 'tagged type rep)))) -(xdef 'annotate ar-tag) +(xdef annotate ar-tag) ; (type nil) -> sym @@ -675,14 +782,14 @@ ((exn? x) 'exception) ((thread? x) 'thread) (#t (err "Type: unknown type" x)))) -(xdef 'type ar-type) +(xdef type ar-type) (define (ar-rep x) (if (ar-tagged? x) (vector-ref x 2) x)) -(xdef 'rep ar-rep) +(xdef rep ar-rep) ; currently rather a joke: returns interned symbols @@ -692,44 +799,35 @@ (set! ar-gensym-count (+ ar-gensym-count 1)) (string->symbol (string-append "gs" (number->string ar-gensym-count)))) -(xdef 'uniq ar-gensym) +(xdef uniq ar-gensym) -(xdef 'ccc call-with-current-continuation) +(xdef ccc call-with-current-continuation) -(xdef 'infile open-input-file) +(xdef infile open-input-file) -(xdef 'outfile (lambda (f . args) +(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) +(xdef instring open-input-string) +(xdef outstring open-output-string) ; use as general fn for looking inside things -(xdef 'inside get-output-string) - -(xdef 'close (lambda 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) - 'nil)) +(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 stdout current-output-port) ; should be a vars +(xdef stdin current-input-port) +(xdef stderr current-error-port) -(xdef 'call-w/stdout +(xdef call-w/stdout (lambda (port thunk) (parameterize ((current-output-port port)) (thunk)))) -(xdef 'call-w/stdin +(xdef call-w/stdin (lambda (port thunk) (parameterize ((current-input-port port)) (thunk)))) @@ -737,56 +835,58 @@ ; nil stream means stdout ; returns nil on eof -(xdef 'readc (lambda (str) +(xdef readc (lambda (str) (let ((p (if (ar-false? str) (current-input-port) str))) (let ((c (read-char p))) (if (eof-object? c) 'nil c))))) -(xdef 'readb (lambda (str) +(xdef readb (lambda (str) (let ((p (if (ar-false? str) (current-input-port) str))) (let ((c (read-byte p))) (if (eof-object? c) 'nil c))))) -(xdef 'peekc (lambda (str) +(xdef peekc (lambda (str) (let ((p (if (ar-false? str) (current-input-port) str))) (let ((c (peek-char p))) (if (eof-object? c) 'nil c))))) -(xdef 'writec (lambda (c . args) +(xdef writec (lambda (c . args) (write-char c (if (pair? args) (car args) (current-output-port))) c)) -(xdef 'writeb (lambda (b . args) +(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)) - (flush-output port)) - 'nil) + (unless explicit-flush (flush-output port))) + 'nil) -(xdef 'write (lambda args (printwith write args))) -(xdef 'disp (lambda args (printwith display args))) +(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) +(xdef sread (lambda (p eof) (let ((expr (read p))) (if (eof-object? expr) eof expr)))) @@ -795,71 +895,82 @@ (define char->ascii char->integer) (define ascii->char integer->char) -(xdef 'coerce (lambda (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)))) - ((integer? x) (case type - ((char) (ascii->char x)) - ((string) (apply number->string x args)) - (else (err "Can't coerce" x type)))) - ((number? x) (case type - ((int) (round x)) - ((char) (ascii->char (round 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))) - ((int) (or (apply string->number x args) - (err "Can't coerce" x type))) - (else (err "Can't coerce" x type)))) - ((pair? x) (case type - ((string) (list->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)))) - ((symbol? x) (case type - ((string) (symbol->string x)) - (else (err "Can't coerce" x type)))) - (#t x)))) - -(xdef 'open-socket (lambda (num) (tcp-listen num 50 #t))) +(define (iround x) (inexact->exact (round x))) + +(xdef coerce + (lambda (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)))) + ((integer? x) (case type + ((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))) + ((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) (list->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)))) + ((symbol? x) (case type + ((string) (symbol->string x)) + (else (err "Can't coerce" x type)))) + (#t x)))) + +(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) - (call-with-values +(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) - (list (make-limited-input-port in 100000 #t) - out - (let-values (((us them) (tcp-addresses out))) - them)))))) - -(xdef 'new-thread thread) -(xdef 'kill-thread kill-thread) -(xdef 'break-thread break-thread) + (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)))))))) + +(xdef new-thread thread) +(xdef kill-thread kill-thread) +(xdef break-thread break-thread) (define (wrapnil f) (lambda args (apply f args) 'nil)) -(xdef 'sleep (wrapnil sleep)) +(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 system (wrapnil system)) -(xdef 'pipe-from (lambda (cmd) +(xdef pipe-from (lambda (cmd) (let ((tf (ar-tmpname))) (system (string-append cmd " > " tf)) (let ((str (open-input-file tf))) @@ -884,9 +995,9 @@ ; PLT scheme provides only eq? and equal? hash tables, ; we need the latter for strings. -(xdef 'table (lambda () (make-hash-table 'equal))) +(xdef table (lambda () (make-hash-table 'equal))) -;(xdef 'table (lambda args +;(xdef table (lambda args ; (fill-table (make-hash-table 'equal) ; (if (pair? args) (ac-denil (car args)) '())))) @@ -897,32 +1008,43 @@ (begin (hash-table-put! h (car pair) (cadr pair)) (fill-table h (cdr pairs)))))) -(xdef 'maptable (lambda (fn table) ; arg is (fn (key value) ...) +(xdef maptable (lambda (fn table) ; arg is (fn (key value) ...) (hash-table-for-each table fn) table)) -(xdef 'protect (lambda (during after) - (dynamic-wind (lambda () #t) during after))) +(define (protect during after) + (dynamic-wind (lambda () #t) during after)) + +(xdef protect protect) ; need to use a better seed -(xdef 'rand random) +(xdef rand random) + +(xdef dir (lambda (name) + (ac-niltree (map path->string (directory-list name))))) -(xdef 'dir (lambda (name) (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) +(xdef file-exists (lambda (name) (if (file-exists? name) name 'nil))) -(xdef 'dir-exists (lambda (name) +(xdef dir-exists (lambda (name) (if (directory-exists? name) name 'nil))) -(xdef 'rmfile (wrapnil delete-file)) +(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 '()) (interaction-environment))) + (eval (ac expr '()))) (define (tle) (display "Arc> ") @@ -990,7 +1112,7 @@ (if (eof-object? x) #t (let ((scm (ac x '()))) - (eval scm (interaction-environment)) + (eval scm) (pretty-print scm op) (newline op) (newline op) @@ -1008,12 +1130,12 @@ (lambda (op) (acompile1 ip op))))))) -(xdef 'macex (lambda (e) (ac-macex (ac-denil e)))) +(xdef macex (lambda (e) (ac-macex (ac-denil e)))) -(xdef 'macex1 (lambda (e) (ac-macex (ac-denil e) 'once))) +(xdef macex1 (lambda (e) (ac-macex (ac-denil e) 'once))) -(xdef 'eval (lambda (e) - (eval (ac (ac-denil e) '()) (interaction-environment)))) +(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. @@ -1025,7 +1147,7 @@ (with-handlers ((exn:fail? (lambda (c) (k (lambda () (errfn c)))))) (f))))))) -(xdef 'on-err on-err) +(xdef on-err on-err) (define (disp-to-string x) (let ((o (open-output-string))) @@ -1033,16 +1155,16 @@ (close-output-port o) (get-output-string o))) -(xdef 'details (lambda (c) +(xdef details (lambda (c) (disp-to-string (exn-message c)))) -(xdef 'scar (lambda (x val) +(xdef scar (lambda (x val) (if (string? x) (string-set! x 0 val) (set-car! x val)) val)) -(xdef 'scdr (lambda (x val) +(xdef scdr (lambda (x val) (if (string? x) (err "Can't set cdr of a string" x) (set-cdr! x val)) @@ -1059,14 +1181,17 @@ (string-set! str i (string-ref val (- i index)))) (err "Length mismatch between strings" str val index))) -(xdef 'sref (lambda (com val ind) ; later make ind rest arg - (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)) +; 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) (set-car! (list-tail lst n) val)) @@ -1078,24 +1203,24 @@ #t (lambda () #f))) -(xdef 'bound (lambda (x) (tnil (bound? x)))) +(xdef bound (lambda (x) (tnil (bound? x)))) -(xdef 'newstring make-string) +(xdef newstring make-string) -(xdef 'trunc (lambda (x) (inexact->exact (truncate x)))) +(xdef trunc (lambda (x) (inexact->exact (truncate x)))) -(xdef 'exact (lambda (x) +(xdef exact (lambda (x) (tnil (and (integer? x) (exact? x))))) -(xdef 'msec current-milliseconds) -(xdef 'current-process-milliseconds current-process-milliseconds) -(xdef 'current-gc-milliseconds current-gc-milliseconds) +(xdef msec current-milliseconds) +(xdef current-process-milliseconds current-process-milliseconds) +(xdef current-gc-milliseconds current-gc-milliseconds) -(xdef 'seconds current-seconds) +(xdef seconds current-seconds) (print-hash-table #t) -(xdef 'client-ip (lambda (port) +(xdef client-ip (lambda (port) (let-values (((x y) (tcp-addresses port))) y))) @@ -1103,40 +1228,112 @@ ; 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. -; XXX make sure cell is set #f after an exception? -; maybe it doesn't matter since thread will die? (define ar-the-sema (make-semaphore 1)) (define ar-sema-cell (make-thread-cell #f)) -(xdef 'atomic-invoke (lambda (f) +(xdef atomic-invoke (lambda (f) (if (thread-cell-ref ar-sema-cell) (ar-apply f '()) (begin (thread-cell-set! ar-sema-cell #t) - (let ((ret - (call-with-semaphore - ar-the-sema - (lambda () (ar-apply f '()))))) - (thread-cell-set! ar-sema-cell #f) - ret))))) + (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)))) +(xdef dead (lambda (x) (tnil (thread-dead? x)))) -; Added because Mzscheme buffers output. Not sure if want as official -; part of Arc. +; 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 flushout (lambda () (flush-output) 't)) -(xdef 'ssyntax (lambda (x) (tnil (ssyntax? x)))) +(xdef ssyntax (lambda (x) (tnil (ssyntax? x)))) -(xdef 'ssexpand (lambda (x) +(xdef ssexpand (lambda (x) (if (symbol? x) (expand-ssyntax x) x))) -(xdef 'quit exit) +(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) + (case key + ((direct-calls) + (set! direct-calls (not (eq? val 'nil)))) + ((explicit-flush) + (set! explicit-flush (not (eq? val 'nil))))))) + +(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 log log) ) -(require ac) ac.scm @@ -1,12 +1,13 @@ ; Application Server. Layer inserted 2 Sep 06. -; todo: def a general notion of apps of which the programming app is -; one and the news site another. +; 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") @@ -16,6 +17,7 @@ (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)) @@ -26,8 +28,8 @@ (= 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))) + (let u (aand (alref req!cooks "user") (cookie->user* (sym it))) + (when u (= (logins* u) req!ip)) u)) (mac when-umatch (user req . body) @@ -35,7 +37,8 @@ (do ,@body) (mismatch-message))) -(def mismatch-message () (prn "Dead link: users don't match.")) +(def mismatch-message () + (prn "Dead link: users don't match.")) (mac when-umatch/r (user req . body) `(if (is ,user (get-user ,req)) @@ -57,10 +60,10 @@ ,@body)) ; Like onlink, but checks that user submitting the request is the -; same it was generated for. Really should log the username and -; ip addr of every genlink, and check if they match. +; same it was generated for. For extra protection could log the +; username and ip addr of every genlink, and check if they match. -(mac userlink (user text . body) +(mac ulink (user text . body) (w/uniq req `(linkf ,text (,req) (when-umatch ,user ,req ,@body)))) @@ -99,9 +102,6 @@ (admin-page user)))))) (pwfields "create (server) account")))) -; need to define a notion of a hashtable that's always written -; to a file when modified - (def cook-user (user) (let id (new-user-cookie) (= (cookie->user* id) user @@ -121,6 +121,7 @@ (save-table cookie->user* cookfile*)) (def create-acct (user pw) + (set (dc-usernames* (downcase user))) (set-pw user pw)) (def disable-acct (user) @@ -137,75 +138,62 @@ (defop login req (login-page 'login)) ; switch is one of: register, login, both -; afterward is a function on the newly created user, ip addr -; or can be a list of such a fn and a string, in which case call fn -; then redirect to string + +; 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. -; ugly code-- too much duplication - (def login-page (switch (o msg nil) (o afterward hello-page)) (whitepage (pagemessage msg) (when (in switch 'login 'both) - (prbold "Login") - (br2) - (if (acons afterward) - (let (f url) afterward - (arformh (fn (req) - (logout-user (get-user req)) - (aif (good-login (arg req "u") (arg req "p") (req 'ip)) - (do (= (logins* it) (req 'ip)) - (prcookie (user->cookie* it)) - (f it (req 'ip)) - url) - (flink (fn ignore (login-page switch - "Bad login." - afterward))))) - (pwfields))) - (aformh (fn (req) - (logout-user (get-user req)) - (aif (good-login (arg req "u") (arg req "p") (req 'ip)) - (do (= (logins* it) (req 'ip)) - (prcookie (user->cookie* it)) - (prn) - (afterward it (req 'ip))) - (do (prn) - (login-page switch "Bad login." afterward)))) - (pwfields))) + (login-form "Login" switch login-handler afterward) + (hook 'login-form afterward) (br2)) (when (in switch 'register 'both) - (prbold "Create Account") - (br2) - (if (acons afterward) - (let (f url) afterward - (arformh (fn (req) - (logout-user (get-user req)) - (with (user (arg req "u") pw (arg req "p")) - (aif (bad-newacct user pw) - (flink (fn ignore - (login-page switch it afterward))) - (do (create-acct user pw) - (= (logins* user) (req 'ip)) - (prcookie (cook-user user)) - (f user (req 'ip)) - url)))) - (pwfields "create account"))) - (aformh (fn (req) - (logout-user (get-user req)) - (with (user (arg req "u") pw (arg req "p")) - (aif (bad-newacct user pw) - (do (prn) - (login-page switch it afterward)) - (do (create-acct user pw) - (= (logins* user) (req 'ip)) - (prcookie (cook-user user)) - (prn) - (afterward user (req 'ip)))))) - (pwfields "create account")))))) - + (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")) @@ -226,8 +214,6 @@ (do (enq-limit record bad-logins*) nil)))) -; can remove this once sha1 installed on pi - ; 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. @@ -238,13 +224,20 @@ (do1 (cut res 0 (- (len res) 1)) (rmfile fname))))) +(= dc-usernames* (table)) + +(def username-taken (user) + (when (empty dc-usernames*) + (ontable 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." - (let dcuser (downcase user) - (some [is dcuser (downcase _)] (keys hpasswords*))) + (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 @@ -260,7 +253,6 @@ (or (no max) (<= (len str) max)) str)) - (defop logout req (aif (get-user req) (do (logout-user it) @@ -269,14 +261,13 @@ (defop whoami req (aif (get-user req) - (prs it 'at (req 'ip)) + (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* 8 formatdoc-url* nil) +(= 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 @@ -284,7 +275,7 @@ (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) + (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)) @@ -296,6 +287,8 @@ (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) @@ -317,7 +310,11 @@ (is typ 'yesno) (menu id '("yes" "no") (if val "yes" "no")) (is typ 'hexcol) - (gentag input type 'text name id value val); was (hexrep val) + (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)) @@ -327,11 +324,14 @@ (+ pad (max (+ 1 (count #\newline text)) (roundup (/ (len text) (- cols 5)))))) -(def varline (typ id val) +(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))) @@ -348,8 +348,8 @@ (def readvar (typ str (o fail nil)) (case (carif typ) string (striptags str) - string1 (if (is str "") fail (striptags str)) - url (if (is str "") str (valid-url str) (striptags str) fail) + 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)) @@ -359,21 +359,20 @@ doc (striptags str) mdtext (md-from-form str) mdtext2 (md-from-form str t) ; for md with no links - ; sym (aif (tokens str) (sym (car it)) fail) - ; syms (map sym (tokens str)) + 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 (or (splitlines (= sss str)) fail) + lines (lines str) choice (readvar (cadr typ) str) yesno (is str "yes") - hexcol (if (hex>color str) str fail) ; was (or (hex>color str) fail) + 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))) -(def splitlines (str) - (map [rem #\return _] (split (cons #\newline "") str))) - (= fail* (uniq)) ; Takes a list of fields of the form (type label value view modify) and @@ -382,30 +381,35 @@ (def vars-form (user fields f done (o button "update") (o lasts)) (timed-aform lasts - (fn (req) - (when-umatch user req - (each (k v) (req 'args) - (let name (sym k) - (awhen (find [is (cadr _) name] fields) - (let (typ id val mod) it - (when (and mod v) - (let newval (readvar typ v fail*) - (unless (is newval fail*) - (f name newval)))))))) - (done))) + (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) +(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 varline) typ id val))) + (td (if mod + (varfield typ id val) + (varline typ id val liveurls)))) (prn)))) ; http://daringfireball.net/projects/markdown/syntax @@ -437,7 +441,7 @@ (or (litmatch "http://" s i) (litmatch "https://" s i))) (withs (n (urlend s i) - url (cut s i n)) + url (clean-url (cut s i n))) (tag (a href url rel 'nofollow) (pr (if (no maxurl) url (ellipsize url maxurl)))) (= i (- n 1))) @@ -455,12 +459,30 @@ (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. @@ -470,19 +492,30 @@ ; with &, which is treated as part of the url. Perhaps the answer ; is just to esc<>& after markdown instead of before. -(def urlend (s i) +; 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 delimc whitec) c) i (+ i 1)) + (if ((orf punc whitec opendelim) c) + i + (closedelim c) + (if indelim (+ i 1) i) + (+ i 1)) (if (or (whitec c) - (delimc c) - (and (punc c) - ((orf whitec delimc) (s (+ i 1))))) + (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)))))) + (urlend s (+ i 1) (or (opendelim c) + (and indelim (no (closedelim c))))))))) -(def delimc (c) - (in c #\( #\) #\[ #\] #\{ #\} #\")) +(def opendelim (c) (in c #\< #\( #\[ #\{)) + +(def closedelim (c) (in c #\> #\) #\] #\})) (def code-block (s i) @@ -523,6 +556,100 @@ (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 "pm") + (+ h 12) + h) + 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) app.arc @@ -1,20 +1,16 @@ ; Main Arc lib. Ported to Scheme version Jul 06. -; optimize ~foo in functional position in ac, like compose +; 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) -; rename assert -; (10 x) for (= x 10)? -; should (= x) mean (= x t)? ; add sigs of ops defined in ac.scm ; get hold of error types within arc -; why is macex defined in scheme instead of using def below? +; does macex have to be defined in scheme instead of using def below? ; write disp, read, write in arc -; could prob write rmfile and dir in terms of system ; could I get all of macros up into arc.arc? ; warn when shadow a global name -; permanent objs that live on disk and are updated when modified -; way to spec default 0 rather than nil for hts -; do in access call or when ht created? simply have ++ nil -> 1? ; some simple regexp/parsing plan ; compromises in this implementation: @@ -22,23 +18,25 @@ ; (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 -(set do (annotate 'mac - (fn args `((fn () ,@args))))) +(assign do (annotate 'mac + (fn args `((fn () ,@args))))) -(set safeset (annotate 'mac - (fn (var val) - `(do (if (bound ',var) - (do (disp "*** redefining ") - (disp ',var) - (writec #\newline))) - (set ,var ,val))))) +(assign safeset (annotate 'mac + (fn (var val) + `(do (if (bound ',var) + (do (disp "*** redefining " (stderr)) + (disp ',var (stderr)) + (disp #\newline (stderr)))) + (assign ,var ,val))))) -(set def (annotate 'mac - (fn (name parms . body) - `(do (sref sig ',parms ',name) - (safeset ,name (fn ,parms ,@body)))))) +(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))) @@ -50,7 +48,17 @@ (def atom (x) (no (acons x))) -(def list args args) +; 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) @@ -69,10 +77,10 @@ (cons (f (car xs) (cadr xs)) (pair (cddr xs) f)))) -(set mac (annotate 'mac - (fn (name parms . body) - `(do (sref sig ',parms ',name) - (safeset ,name (annotate 'mac (fn ,parms ,@body))))))) +(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 @@ -118,11 +126,11 @@ (mac rfn (name parms . body) `(let ,name nil - (set ,name (fn ,parms ,@body)))) + (assign ,name (fn ,parms ,@body)))) (mac afn (parms . body) `(let self nil - (set self (fn ,parms ,@body)))) + (assign self (fn ,parms ,@body)))) ; Ac expands x:y:z into (compose x y z), ~x into (complement x) @@ -138,6 +146,8 @@ `(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))))) @@ -171,7 +181,7 @@ `(let ,g ,x (or ,@(map1 (fn (c) `(is ,g ,c)) choices))))) -; should take n args +; Could take n args, but have never once needed that. (def iso (x y) (or (is x y) @@ -284,6 +294,11 @@ (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))) @@ -304,6 +319,7 @@ (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 @@ -317,7 +333,7 @@ ; 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? -(set setter (table)) +(assign setter (table)) (mac defset (name parms . body) (w/uniq gexpr @@ -368,25 +384,27 @@ (if (ssyntax expr) (setforms (ssexpand expr)) (w/uniq (g h) - (list (list g expr) + (list (list g expr) g - `(fn (,h) (set ,expr ,h))))) + `(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" + (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 ,@argsyms))))))))))) + `(fn (,h) (sref ,g ,h ,(car argsyms)))))))))))) (def metafn (x) (or (ssyntax x) @@ -394,18 +412,20 @@ (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)) - (err "Can't invert " (cons f args)))) + ((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)) - `(set ,place ,val) + `(assign ,place ,val) (let (vars prev setter) (setforms place) (w/uniq g `(atwith ,(+ vars (list g val)) @@ -429,7 +449,7 @@ (mac for (v init max . body) (w/uniq (gi gm) `(with (,v nil ,gi ,init ,gm (+ ,max 1)) - (loop (set ,v ,gi) (< ,v ,gm) (set ,v (+ ,v 1)) + (loop (assign ,v ,gi) (< ,v ,gm) (assign ,v (+ ,v 1)) ,@body)))) (mac repeat (n . body) @@ -454,8 +474,10 @@ ; (nthcdr x y) = (cut y x). -(def cut (seq start (o end (len seq))) - (let end (if (< end 0) (+ (len seq) end) end) +(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) @@ -491,8 +513,15 @@ (def keep (test seq) (rem (complement (testify test)) seq)) -(def trues (f seq) - (rem nil (map f 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 @@ -612,7 +641,7 @@ (mac wipe args `(do ,@(map (fn (a) `(= ,a nil)) args))) -(mac assert args +(mac set args `(do ,@(map (fn (a) `(= ,a t)) args))) ; Destructuring means ambiguity: are pat vars bound in else? (no) @@ -646,7 +675,7 @@ (w/uniq gacc `(withs (,gacc nil ,accfn [push _ ,gacc]) ,@body - ,gacc))) + (rev ,gacc)))) ; Repeatedly evaluates its body till it returns nil, then returns vals. @@ -665,11 +694,9 @@ (mac whiler (var expr endval . body) (w/uniq gf - `((rfn ,gf (,var) - (when (and ,var (no (is ,var ,endval))) - ,@body - (,gf ,expr))) - ,expr))) + `(withs (,var nil ,gf (testify ,endval)) + (while (no (,gf (= ,var ,expr))) + ,@body)))) ;(def macex (e) ; (if (atom e) @@ -684,13 +711,11 @@ (def string args (apply + "" (map [coerce _ 'string] args))) -(def flat (x (o stringstoo)) - ((rfn f (x acc) - (if (or (no x) (and stringstoo (is x ""))) - acc - (and (atom x) (no (and stringstoo (isa x 'string)))) - (cons x acc) - (f (car x) (f (cdr x) acc)))) +(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)) @@ -739,6 +764,9 @@ (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)))) @@ -767,12 +795,12 @@ (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 writefile1 (val name) (w/outfile s name (write val s)) val) - (def readall (src (o eof nil)) ((afn (i) (let x (read i eof) @@ -781,8 +809,16 @@ (cons x (self i))))) (if (isa src 'string) (instring src) src))) +(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 @@ -795,14 +831,18 @@ (repeat ,n (push ,expr ,ga)) (rev ,ga)))) +; rejects bytes >= 248 lest digits be overrepresented + (def rand-string (n) - (with (cap (fn () (+ 65 (rand 26))) - sm (fn () (+ 97 (rand 26))) - dig (fn () (+ 48 (rand 10)))) - (coerce (map [coerce _ 'char] - (cons (rand-choice (cap) (sm)) - (n-of (- n 1) (rand-choice (cap) (sm) (dig))))) - 'string))) + (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)) @@ -869,33 +909,41 @@ ; right no of args and didn't have to call apply (or list if 1 arg). (def memo (f) - (let cache (table) + (with (cache (table) nilcache (table)) (fn args (or (cache args) - (= (cache args) (apply f 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) + (or (no args) (no (cdr args)) (and (no (> (car args) (cadr args))) (apply <= (cdr args))))) (def >= args - (or (no 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 alphadig (c) - (or (<= #\a c #\z) (<= #\A c #\Z) (<= #\0 c #\9))) +(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 #\. #\, #\; #\: #\! #\?)) @@ -904,7 +952,7 @@ (awhen (readc str) (tostring (writec it) - (whiler c (readc str) #\newline + (whiler c (readc str) [in _ nil #\newline] (writec c))))) ; Don't currently use this but suspect some code could. @@ -916,6 +964,11 @@ ,@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) @@ -959,13 +1012,6 @@ (each (k v) (pair data) (= (table k) v)) table) -(mac obj args - (w/uniq g - `(let ,g (table) - ,@(map (fn ((k v)) `(= (,g ',k) ,v)) - (pair args)) - ,g))) - (def keys (h) (accum a (ontable k v h (a k)))) @@ -983,6 +1029,11 @@ 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))) @@ -996,7 +1047,7 @@ (drain (read-table i eof) eof)))) (def save-table (h file) - (w/outfile o file (write-table h o))) + (writefile (tablist h) file)) (def write-table (h (o o (stdout))) (write (tablist h) o)) @@ -1004,7 +1055,7 @@ (def copy (x . args) (let x2 (case (type x) sym x - cons (apply (fn args args) x) + cons (copylist x) ; (apply (fn args args) x) string (let new (newstring (len x)) (forlen i x (= (new i) (x i))) @@ -1038,11 +1089,14 @@ ((if (> n 0) + -) base 1) base))) -(def to-nearest (n quantum) +(def nearest (n quantum) (* (roundup (/ n quantum)) quantum)) (def avg (ns) (/ (apply + ns) (len ns))) +(def med (ns (o test >)) + ((sort > 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) @@ -1094,14 +1148,14 @@ (if (no x) y (no y) x (let lup nil - (set 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)))))) + (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) @@ -1113,10 +1167,12 @@ (firstn n (sort f seq))) (def split (seq pos) - (withs (mid (nthcdr (- pos 1) seq) - s2 (cdr mid)) - (wipe (cdr mid)) - (list seq s2))) + (if (< pos 1) + (list nil seq) + (withs (mid (nthcdr (- pos 1) seq) + s2 (cdr mid)) + (wipe (cdr mid)) + (list seq s2)))) (mac time (expr) (w/uniq (t1 t2) @@ -1186,9 +1242,11 @@ (def since (t1) (- (seconds) t1)) -(def hours-since (t1) (/ (since t1) 60)) +(def minutes-since (t1) (/ (since t1) 60)) +(def hours-since (t1) (/ (since t1) 3600)) +(def days-since (t1) (/ (since t1) 86400)) -(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) @@ -1198,23 +1256,30 @@ 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 saferead (arg) (errsafe:read arg)) (def safe-load-table (filename) - (or (errsafe (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 time (seconds))) - (let val (tostring (system (string "date -u -r " time " \"+%Y-%m-%d\""))) - (cut val 0 (- (len val) 1)))) +(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)) @@ -1227,7 +1292,7 @@ str (+ (cut str 0 limit) "..."))) -(def random-elt (seq) +(def rand-elt (seq) (seq (rand (len seq)))) (mac until (test . body) @@ -1276,34 +1341,32 @@ `(with (,gf ,f ,gx ,x) (if (,gf ,gx) (cons ,gx ,y) ,y)))) -; Could rename this get, but don't unless it's frequently used. ; Could combine with firstn if put f arg last, default to (fn (x) t). -(def firstn-that (n f xs) - (if (or (<= n 0) (no xs)) - nil - (f (car xs)) - (cons (car xs) (firstn-that (- n 1) f (cdr xs))) - (firstn-that n f (cdr xs)))) +(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) - (assert (h x)))) + (set (h x)))) (rev acc))) (def single (x) (and (acons x) (no (cdr x)))) (def intersperse (x ys) - (cons (car ys) - (mappend [list x _] (cdr ys)))) + (and ys (cons (car ys) + (mappend [list x _] (cdr ys))))) (def counts (seq (o c (table))) (if (no seq) c - (do (zap [if _ (+ _ 1) 1] (c (car seq))) + (do (++ (c (car seq) 0)) (counts (cdr seq) c)))) (def commonest (seq) @@ -1325,21 +1388,21 @@ (let argsym (uniq) (def parse-format (str) - (rev (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))))))) + (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) @@ -1348,11 +1411,9 @@ (def load (file) (w/infile f file - (whilet e (read f) - (eval e)))) - -(def positive (x) - (and (number x) (> x 0))) + (w/uniq eof + (whiler e (read f eof) eof + (eval e))))) (mac w/table (var . body) `(let ,var (table) ,@body ,var)) @@ -1404,12 +1465,11 @@ (each ,var ,val (when (multiple (++ ,gc) ,gn) (pr ".") - ;(flushout) + (flushout) ) ,@body) (prn) - ;(flushout) - ))) + (flushout)))) (mac point (name . body) (w/uniq g @@ -1457,7 +1517,7 @@ (def memtable (ks) (let h (table) - (each k ks (assert (h k))) + (each k ks (set (h k))) h)) (= bar* " | ") @@ -1470,7 +1530,7 @@ (unless (is ,out "") (if ,needbars (pr bar* ,out) - (do (assert ,needbars) + (do (set ,needbars) (pr ,out)))))) body))))) @@ -1488,6 +1548,11 @@ ,@(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) @@ -1496,6 +1561,32 @@ (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)))) + ; any logical reason I can't say (push x (if foo y z)) ? @@ -1503,6 +1594,12 @@ ; 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 ""))) arc.arc @@ -5,7 +5,7 @@ (require mzscheme) ; promise we won't redefine mzscheme bindings -(load "ac.scm") +(require "ac.scm") (require "brackets.scm") (use-bracket-readtable) as.scm @@ -1,4 +1,4 @@ -; Blog tool example. 20 Jan 08. +; Blog tool example. 20 Jan 08, rev 21 May 09. ; To run: ; arc> (load "blog.arc") @@ -9,20 +9,16 @@ (= blogtitle* "A Blog") -(deftem post - id nil - title nil - text nil) +(deftem post id nil title nil text nil) (def load-posts () - (each id (map [coerce _ 'int] (dir postdir*)) + (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 save-post (p) (save-table p (string postdir* p!id))) -(def post (id) (posts* (errsafe (coerce id 'int)))) +(def post (id) (posts* (errsafe:int id))) (mac blogpage body `(whitepage @@ -35,52 +31,44 @@ (w/bars (link "archive") (link "new post" "newpost")))))) -(defop viewpost req +(defop viewpost req (blogop post-page req)) + +(def blogop (f req) (aif (post (arg req "id")) - (post-page (get-user req) it) - (notfound))) + (f (get-user req) it) + (blogpage (pr "No such post.")))) -(def permalink (p) (string "viewpost?id=" (p 'id))) +(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))) + (tag b (link p!title (permalink p))) (when user (sp) - (link "[edit]" (string "editpost?id=" (p 'id)))) + (link "[edit]" (string "editpost?id=" p!id))) (br2) - (pr (p 'text))) - -(def notfound () - (blogpage (pr "No such post."))) + (pr p!text)) (defopl newpost req (whitepage - (aform (fn (req) - (let user (get-user req) - (post-page user - (addpost user (arg req "t") (arg req "b"))))) - (tab - (row "title" (input "t" "" 60)) - (row "text" (textarea "b" 10 80)) - (row "" (submit)))))) + (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))) + (= (posts* p!id) p))) -(defopl editpost req - (aif (post (arg req "id")) - (edit-page (get-user req) it) - (notfound))) +(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)) + `((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))))) @@ -89,7 +77,7 @@ (blogpage (tag ul (each p (map post (rev (range 1 maxid*))) - (tag li (link (p 'title) (permalink p))))))) + (tag li (link p!title (permalink p))))))) (defop blog req (let user (get-user req) blog.arc @@ -7,7 +7,7 @@ (w/infile in file (summing test (whilet line (readline in) - (test (aand (pos nonwhite line) (isnt it #\;))))))) + (test (aand (find nonwhite line) (isnt it #\;))))))) (def codeflat (file) (len (flat (readall (infile file))))) @@ -22,8 +22,7 @@ (let counts (table) (each f files (each token (flat (readall (infile f))) - (= (counts token) - (+ 1 (or (counts token) 0))))) + (++ (counts token 0)))) counts)) (def common-tokens (files) code.arc @@ -23,19 +23,17 @@ 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)) -; hack: intern key pair till have implicit tables of tables - -(mac opmeth (tag opt) - `(opmeths* (sym (+ (string ,tag) "." (string ,opt))))) +(mac opmeth args + `(opmeths* (list ,@args))) (mac attribute (tag opt f) -; `(= (opmeth ',tag ',opt) ,f) - `(= (opmeths* ',(sym (+ (string tag) "." (string opt)))) - ,f)) + `(= (opmeths* (list ',tag ',opt)) ,f)) (= hexreps (table)) @@ -147,13 +145,30 @@ (def start-tag (spec) (if (atom spec) - `(pr "<" ',spec ">") - `(do (pr "<" ',(car spec)) - ,@(tag-options (car spec) (pair (cdr spec))) - (pr ">")))) + `(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 "</" ',(carif spec) ">")) + `(pr ,(string "</" (carif spec) ">"))) + +(def literal (x) + (case (type x) + sym (in x nil t) + cons (caris x 'quote) + t)) + +; Returns a list whose elements are either strings, which can +; simply be printed out, or expressions, which when evaluated +; generate output. (def tag-options (spec options) (if (no options) @@ -162,7 +177,9 @@ (let meth (if (is opt 'style) opstring (opmeth spec opt)) (if meth (if val - (cons (meth opt val) + (cons (if (literal val) + (tostring (eval (meth opt val))) + (meth opt val)) (tag-options spec rest)) (tag-options spec rest)) (do @@ -189,7 +206,7 @@ (mac td body `(tag td ,@(pratoms body))) (mac trtd body `(tr (td ,@(pratoms body)))) - (mac tdright body `(tag (td align 'right) ,@(pratoms body))) + (mac tdr body `(tag (td align 'right) ,@(pratoms body))) (mac tdcolor (col . body) `(tag (td bgcolor ,col) ,@(pratoms body))) ) @@ -201,7 +218,7 @@ `(tr ,@(map (fn (a) `(let ,g ,a (if (number ,g) - (tdright (pr ,g)) + (tdr (pr ,g)) (td (pr ,g))))) args)))) @@ -248,8 +265,10 @@ `(tag (table border 0 cellpadding 0 cellspacing 0) ,@body)) +; was `(tag (table border 0 cellpadding 0 cellspacing 7) ,@body) + (mac sptab body - `(tag (table border 0 cellpadding 0 cellspacing 7) ,@body)) + `(tag (table style "border-spacing: 7px 0px;") ,@body)) (mac widtable (w . body) `(tag (table width ,w) (tr (td ,@body)))) @@ -342,10 +361,13 @@ (let intag nil (tostring (each c s - (if (is c #\<) (assert intag) + (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))) @@ -357,7 +379,7 @@ (tostring (each c str (pr c) - (unless (whitec c) (assert ink)) + (unless (whitec c) (set ink)) (when (is c #\newline) (unless ink (pr "<p>")) (wipe ink)))))) @@ -367,3 +389,15 @@ (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) + `(tag (font color ,c) ,@body)) html.arc @@ -4,5 +4,4 @@ "html.arc" "srv.arc" "app.arc" - "prompt.arc" - "news.arc")) + "prompt.arc")) libs.arc @@ -1,5 +1,6 @@ ; News. 2 Sep 06. + ; to run news: (nsv) ; put usernames of admins, separated by whitespace, in arc/admins @@ -8,7 +9,7 @@ parent-url* "http://www.yourdomain.com" favicon-url* "" site-desc* "What this site is about." ; for rss feed - site-color* orange + site-color* (color 160 180 200) prefer-url* t) @@ -25,10 +26,11 @@ 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 - nodowns nil email nil about nil showdead nil @@ -38,7 +40,8 @@ maxvisit 20 minaway 180 topcolor nil - keys nil) + keys nil + delay 0) (deftem item id nil @@ -52,10 +55,13 @@ 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) + kids nil + keys nil) ; Load and Save @@ -67,10 +73,12 @@ (= 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 (empty profs*) (load-users)) + (if (and initload-users* (empty profs*)) (load-users)) (asv port)) (def load-users () @@ -78,13 +86,34 @@ (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)) + (= (votes* u) (table) + (profs* u) (inst 'profile 'id u)) (save-votes u) (save-prof u) u) @@ -95,17 +124,42 @@ ; news app need to call this in the after-login fn. (def ensure-news-user (u) - (if (profs* u) u (init-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) `((profs* ,u) ',k)) +(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 set-key (u k) + (do1 (pushnew k (uvar u keys)) + (save-prof u))) + +(def unset-key (u k) + (do1 (pull k (uvar u keys)) + (save-prof u))) + +(def toggle-key (u k) + (do1 (atomic + (if (mem k (uvar u keys)) + (pull k (uvar u keys)) + (push k (uvar u keys)))) + (save-prof u))) -(mac karma (u) `(uvar ,u karma)) +(def author (u i) (is u i!by)) -(def users (f) (keep f (keys profs*))) (= stories* nil comments* nil items* (table) url->story* (table) maxid* 0 initload* 15000) @@ -117,17 +171,21 @@ ; 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 most popular pages. +; 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 [coerce _ 'int] (dir storydir*)))) + 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 items!story) comments* (rev items!comment)) + (= stories* (rev (merge (compare < get!id) + items!story + items!poll)) + comments* (rev items!comment)) (hook 'initload items)) (ensure-topstories)) @@ -135,30 +193,51 @@ (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 (string storydir* id)) - (= (items* id) i (i 'id) id) - (awhen (and (astory i) (live i) i!url) - (= (url->story* it) i)) + (= (items* id) i) + (awhen (and (astory i) (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)) + (stem-url url) + url)) + +(def stem-url (url) + (cut url 0 (pos #\? url))) + (def new-item-id () (let id (++ maxid*) - (if (file-exists (string storydir* id)) (new-item-id) id))) + (if (file-exists (string storydir* id)) + (new-item-id) + id))) (def item (id) - (or (items* id) (errsafe (load-item id)))) + (or (items* id) (errsafe:load-item id))) -(def kids (x) (map item x!kids)) +(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 +; 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) (let id (if (isa id 'string) (saferead id) id) @@ -176,9 +255,29 @@ (def save-item (i) (save-table i (string storydir* i!id))) -(def kill (i) - (assert i!dead) - (save-item i)) +(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 + (when (test i) (a i))))) (def newslog args (apply srvlog 'news args)) @@ -188,17 +287,38 @@ ; Votes divided by the age in hours to the gravityth power. ; Would be interesting to scale gravity in a slider. -(= gravity* 1.4 timebase* 120 front-threshold* 1) +(= 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)) 1 + (blank s!url) nourl-factor* + (lightweight s) (min lightweight-factor* + (contro-factor s)) + (contro-factor s)))) -(def frontpage-rank (s (o gravity gravity*)) - (/ (- (realscore s) 1) - (expt (/ (+ (item-age s) timebase*) 60) gravity))) +(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)) -(def item-age (i) (hours-since i!time)) +(disktable lightweights* (+ newsdir* "lightweights")) -(def user-age (u) (hours-since (uvar u created))) +(def lightweight (s) + (or (mem 'rally s!keys) ; title is a rallying cry + (mem 'image s!keys) ; post is image(s), but without image extension + (or (lightweights* (sitename s!url)) + (in (last (tokens s!url #\.)) + "png" "PNG" "jpg" "JPG" "jpeg" "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. @@ -207,23 +327,38 @@ (= ranked-stories* (rank-stories 180 1000 (memo frontpage-rank)))) (def save-topstories () - (writefile1 (map [_ 'id] (firstn 180 ranked-stories*)) - (+ newsdir* "topstories"))) + (writefile (map get!id (firstn 180 ranked-stories*)) + (+ newsdir* "topstories"))) (def rank-stories (n consider scorefn) (bestn n (compare > scorefn) (recent-stories consider))) -; The n most recent stories. Use firstn when add virtual lists. +; The n most recent stories. + +; with virtual lists would write thus: +; (map item (retrieve n metastory:item (gen maxid* [- _ 1]))) (def recent-stories (n (o id maxid*) (o acc nil)) (if (or (< n 1) (< id 1)) (rev acc) (let s (item id) - (if (storylike s) + (if (metastory s) (recent-stories (- n 1) (- id 1) (cons s acc)) (recent-stories n (- id 1) acc))))) -(def storylike (i) (and i (astory i))) +(def recent-items (test minutes) + (with (cutoff (- (seconds) (* 60 minutes)) + id nil) + (accum a + (loop (= id maxid*) + (and (> id 0) (> ((item id) 'time) cutoff)) + (-- id) + (let i (item id) + (if (test i) (a i))))))) + +; 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*) @@ -234,27 +369,35 @@ ; thus get stuck in front of it. I avoid this by regularly adjusting ; the rank of a random top story. -(def rerank-random ((o depth 15)) +(defbg rerank-random 30 (rerank-random)) + +(def rerank-random () (when ranked-stories* - (adjust-rank (ranked-stories* (rand (min depth (len ranked-stories*)))))) - (save-topstories)) + (adjust-rank (ranked-stories* (rand (min 50 (len ranked-stories*))))))) (def topstories (user n (o threshold front-threshold*)) - (firstn-that n - [and (>= (realscore _) threshold) (cansee user _)] - ranked-stories*)) + (retrieve n + [and (>= (realscore _) threshold) (cansee user _)] + ranked-stories*)) -; If had ip of current request could add clause below to make ignore -; tighter better, but wait till need to. +(= max-delay* 10) (def cansee (user i) - (if i!deleted (admin user) - i!dead (or (is user i!by) (seesdead user)) - ; ip of this request is i!ip - t)) + (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 (uvar user ignore))) + (or (and user (uvar user showdead) (no (ignored user))) (editor user))) (def visible (user is) @@ -278,10 +421,15 @@ (defopr favicon.ico req favicon-url*) +; redefined later + +(def gen-css-url () + (prn "<link rel=\"stylesheet\" type=\"text/css\" href=\"news.css\">")) + (mac npage (title . body) `(tag html (tag head - (prn "<link rel=\"stylesheet\" type=\"text/css\" href=\"news.css\">") + (gen-css-url) (prn "<link rel=\"shortcut icon\" href=\"" favicon-url* "\">") (tag script (pr votejs*)) (tag title (pr ,title))) @@ -293,20 +441,20 @@ (= pagefns* nil) -(mac fulltop (user label title whence . body) - (w/uniq (gu gl gt gw) - `(with (,gu ,user ,gl ,label ,gt ,title ,gw ,whence) +(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 ,gl ,gt ,gu ,gw) + (do (pagetop 'full ,gi ,gl ,gt ,gu ,gw) (hook 'page ,gu ,gl) ,@body) (row (procrast-msg ,gu ,gw))))))) -(mac longpage (user t1 label title whence . body) - (w/uniq (gu gt) - `(with (,gu ,user ,gt ,t1) - (fulltop ,gu ,label ,title ,whence +(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)) @@ -320,6 +468,7 @@ (br2) (w/bars (pr (len items*) "/" maxid* " loaded") + (pr (round (/ (memory) 1000000)) " mb") (pr elapsed " msec") (link "settings" "newsadmin") (hook 'admin-bar user whence)))) @@ -328,15 +477,22 @@ (tag (table width "100%" cellspacing 0 cellpadding 1) (tr (tdcolor c)))) -(mac shortpage (user label title whence . body) - `(fulltop ,user ,label ,title ,whence +(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 ,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))) ; remember to (= caching* 0) or won't see changes @@ -381,7 +537,7 @@ a:visited { color:#828282; text-decoration:none; } .pagebreak {page-break-before:always} -pre { overflow: hidden; padding: 2px; } +pre { overflow: auto; padding: 2px; max-width:600px; } pre:hover {overflow:auto} ")) ; only need pre padding because of a bug in Mac Firefox @@ -435,7 +591,7 @@ function vote(node) { (hex>color it) site-color*)) -(def pagetop (switch label (o title) (o user) (o whence)) +(def pagetop (switch lid label (o title) (o user) (o whence)) (tr (tdcolor (main-color user) (tag (table border 0 cellpadding 0 cellspacing 0 width "100%" style "padding:2px") @@ -460,10 +616,16 @@ function vote(node) { (gentag img src logo-url* width 18 height 18 style "border:1px white solid;")))) -(= toplabels* '(nil "new" "threads" "comments" "leaders" "*")) +(= 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)) @@ -472,7 +634,7 @@ function vote(node) { (hook 'toprow user label) (link "submit") (unless (mem label toplabels*) - (tag (font color white) (pr label))))) + (fontcolor white (pr label))))) (def toplink (name dest label) (tag-if (is name label) (span class 'topsel) @@ -480,7 +642,7 @@ function vote(node) { (def topright (user whence (o showkarma t)) (when user - (link user (user-url user)) + (userlink user user nil) (when showkarma (pr "&nbsp;(" (karma user) ")")) (pr "&nbsp;|&nbsp;")) (if user @@ -492,9 +654,12 @@ function vote(node) { (login-page 'both nil (list (fn (u ip) (ensure-news-user u) - (newslog u 'top-login ip)) + (newslog ip u 'top-login)) whence))))) +(def noob (user) + (and user (< (days-since (uvar user created)) 1))) + ; News-Specific Defop Variants @@ -521,7 +686,7 @@ function vote(node) { (with (user (get-user ,gr) ip (,gr 'ip)) (with ,(and parms (mappend [list _ (list 'arg gr (string _))] parms)) - (newslog user ',name ip ,@parms) + (newslog ip user ',name ,@parms) ,@body))))) (= newsop-names* nil) @@ -534,65 +699,73 @@ function vote(node) { (w/uniq g `(opexpand defopa ,name ,parms (let ,g (string ',name) - (shortpage user ,g ,g ,g + (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 (newsadmin-page (get-user req))) +(defopa newsadmin req + (let user (get-user req) + (newslog req!ip user 'newsadmin) + (newsadmin-page user))) -; For emergency, real-time changes. All are reset to the val in the -; source code when restart server. +; Note that caching* is reset to val in source when restart server. (def nad-fields () - `((num caching ,caching* t t) - (posint front-threshold ,front-threshold* t t) - (int legit-threshold ,legit-threshold* t t) - (bigtoks url-kill ,url-kill* t t) - (bigtoks url-ignore ,url-ignore* t t) - (bigtoks comment-kill ,comment-kill* t t) - (bigtoks comment-ignore ,comment-ignore* t t) - (bigtoks ip-ban ,ip-ban* t t))) + `((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) - (newslog user 'newsadmin) - (shortpage user "newsadmin" "News Admin Page" "newsadmin" - (vars-form user (nad-fields) + (shortpage user nil nil "newsadmin" "newsadmin" + (vars-form user + (nad-fields) (fn (name val) (case name caching (= caching* val) - front-threshold (= front-threshold* val) - legit-threshold (= legit-threshold* val) - url-kill (= url-kill* val) - url-ignore (= url-ignore* val) - comment-kill (= comment-kill* val) - comment-ignore (= comment-ignore* val) - ip-ban (= ip-ban* 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 (profs* subject) + (if (profile subject) (do (killallby subject) (submitted-page user subject)) (if (admin user) (newsadmin-page user))))) - (single-input "" 'id 20 "kill all by")))) + (single-input "" 'id 20 "kill all by")) + (br2) + (aform (fn (req) + (let user (get-user req) + (set-ip-ban user (arg req "ip") t) + (if (admin user) (newsadmin-page user)))) + (single-input "" 'ip 20 "ban ip")))) ; Users (newsop user (id) - (if (profs* 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 (+ "Profile: " subject) here + (shortpage user nil nil (+ "Profile: " subject) here (profile-form user subject) (br2) (when (some astory:item (uvar subject submitted)) @@ -603,7 +776,7 @@ function vote(node) { (hook 'user user subject)))) (def profile-form (user subject) - (let prof (profs* subject) + (let prof (profile subject) (vars-form user (user-fields user subject) (fn (name val) (= (prof name) val)) @@ -619,7 +792,7 @@ function vote(node) { k (and w (> (karma user) topcolor-threshold*)) u (or a w) m (or a (and (member user) w)) - p (profs* subject)) + p (profile subject)) `((string user ,subject t nil) (string name ,(p 'name) ,m ,m) (string created ,(text-age:user-age subject) t nil) @@ -628,10 +801,10 @@ function vote(node) { (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) - (yesno nodowns ,(p 'nodowns) ,a ,a) - (mdtext about ,(p 'about) t ,u) + (mdtext2 about ,(p 'about) t ,u) (string email ,(p 'email) ,u ,u) (yesno showdead ,(p 'showdead) ,u ,u) (yesno noprocrast ,(p 'noprocrast) ,u ,u) @@ -640,11 +813,15 @@ function vote(node) { (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)))) + (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 (len (voted-stories 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))))))) @@ -652,12 +829,15 @@ function vote(node) { (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* 0 perpage* 30 maxend* 200) +(= 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 @@ -680,12 +860,11 @@ function vote(node) { ;(newsop index.html () (newspage user)) (newscache newspage user 90 - (rerank-random) - (listpage user (msec) (topstories user maxend*) nil nil "news" t)) + (listpage user (msec) (topstories user maxend*) nil nil "news")) -(def listpage (user t1 items label title (o url label) (o number)) +(def listpage (user t1 items label title (o url label) (o number t)) (hook 'listpage user) - (longpage user t1 label title url + (longpage user t1 nil label title url (display-items user items label title url 0 perpage* number))) @@ -695,17 +874,16 @@ function vote(node) { ; cached page. If this were a prob, could make deletion clear caches. (newscache newestpage user 40 - (rerank-random) - (listpage user (msec) (newstories user maxend*) "new" "New Links" "newest" t)) + (listpage user (msec) (newstories user maxend*) "new" "New Links" "newest")) (def newstories (user n) - (firstn-that n [cansee user _] stories*)) + (retrieve n [cansee user _] stories*)) (newsop best () (bestpage user)) (newscache bestpage user 1000 - (listpage user (msec) (beststories user maxend*) "best" "Top Links" "best" t)) + (listpage user (msec) (beststories user maxend*) "best" "Top Links")) ; As no of stories gets huge, could test visibility in fn sent to best. @@ -713,33 +891,45 @@ function vote(node) { (bestn n (compare > realscore) (visible user stories*))) +(newsop noobs () (noobpage user)) + +(def noobpage (user) + (listpage user (msec) (noobstories user maxend*) "noobs" "New Accounts")) + +(def noobstories (user n) + (retrieve n [and (cansee user _) (bynoob _)] stories*)) + +(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")) + "best comments" "Best Comments" "bestcomments" nil)) (def bestcomments (user n) (bestn n (compare > realscore) (visible user comments*))) (newsop lists () - (longpage user (msec) "lists" "Lists" "lists" - (tag table - (row "" (hspace 10)) - (row (link "best") "" "Highest voted recent links.") - (row (link "active") "" "Most active current discussions.") - (row (link "bestcomments") "" "Highest voted recent comments.") + (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 "noobs") "Submissions from new accounts.") (when (admin user) (map [row (link _)] - '(optimes killed badguys badlogins goodlogins))) + '(optimes topips flagged killed badguys badlogins goodlogins))) (hook 'listspage user)))) (def saved-url (user) (string "saved?id=" user)) (newsop saved (id) - (if (profs* id) + (if (only.profile id) (savedpage user id) (pr "No such user."))) @@ -747,12 +937,12 @@ function vote(node) { (if (or (is user subject) (admin user)) (listpage user (msec) (sort (compare < item-age) (voted-stories user subject)) - "saved" "Saved Links" (saved-url subject) t) + "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)))) + (map item (keys:votes subject)))) ; Story Display @@ -761,14 +951,14 @@ function vote(node) { (o start 0) (o end perpage*) (o number)) (zerotable (let n start - (each i (if end (cut items start end) items) + (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))) + (tr (tag (td colspan (if number 2 1))) (tag (td class 'title) (morelink items label title end newend number)))))))) @@ -781,8 +971,8 @@ function vote(node) { (afnid (fn (req) (prn) (let user (get-user req) - (newslog user 'more label) - (longpage user (msec) label title (url-for it) + (newslog req!ip user 'more label) + (longpage user (msec) nil label title (url-for it) (display-items user items label title (url-for it) end newend number)))))) @@ -793,19 +983,18 @@ function vote(node) { (when (or (cansee user s) (s 'kids)) (tr (display-item-number i) (td (votelinks s user whence)) - (titlelink s s!url user)) + (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 (astory s) (commentlink s user)) + (when (in s!type 'story 'poll) (commentlink s user)) (editlink s user) - (when (admin user) - (pr bar*) - (w/rlink (do (zap no s!dead) - (save-item s) - whence) - (pr (if (s 'dead) "unkill" "kill")))) + (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) @@ -814,31 +1003,63 @@ function vote(node) { (= follow-threshold* 5) -(def titlelink (s url user) +(def titleline (s url user whence) (tag (td class 'title) (if (cansee user s) - (do (let toself (blank url) - (tag (a href (if toself (item-url s) url) - rel (unless (or toself - (> (realscore s) follow-threshold*)) - 'nofollow)) - (pr (s 'title)))) - (deadmark s user) - (awhen (and (valid-url url) (sitename url)) + (do (deadmark s user) + (titlelink s url user) + (pdflink url) + (awhen (sitename url) (spanclass comhead - (pr " (" it ") ")))) + (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]")) + (pr " [dead] ")) (when (and i!deleted (admin user)) - (pr " [deleted]"))) + (pr " [deleted] "))) -(= downvote-threshold* 20 downvote-time* 1440) +(= downvote-threshold* 100 downvote-time* 1440) (= votewid* 14) @@ -846,7 +1067,7 @@ function vote(node) { (center (if (and (cansee user i) (or (no user) - (no ((votes* user) i!id)))) + (no ((votes user) i!id)))) (do (votelink i user whence 'up) (if (and downtoo (or (admin user) @@ -854,83 +1075,135 @@ function vote(node) { (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 (string "down_" i!id))))) - (is user i!by) - (do (tag (font color orange) (pr "*")) + (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 (string dir '_ i!id) + (tag (a id (if user (string dir '_ i!id)) onclick (if user "return vote(this)") - href (if user - (string "vote?by=" user "&for=" i!id "&dir=" dir) - (flink (vote-fn i whence dir)))) - (gentag img src (case dir up up-url* down down-url*) - border 0 vspace 3 hspace 2))) - -(def vote-fn (i whence dir) - (fn (req) - (login-page 'both "You have to be logged in to vote." - (list (fn (u ip) - (ensure-news-user u) - (newslog u 'vote-login ip) - (vote-for u i dir) - (logvote u i)) - whence)))) + 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?" (if user (+ "by=" user "&") "") + "for=" (coerce i!id 'string) + "&dir=" (coerce dir 'string) + (if user (string "&auth=" (user->cookie* user)) "") + "&whence=" (urlencode whence))) + +(= lowest-score* -8) ; Not much stricter than whether to generate the arrow. Further tests ; applied in vote-for. (def canvote (user i dir) (and user - (no ((votes* user) i!id)) + (news-type i) + (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 (is user ((item it) 'by)))))))) - -; Can't use this for links when not logged in, because doesn't know -; where to redirect after the login. But that's few fnids anyway -; because pages with those links are cached. Now that have Javascript -; voting, can use for all other votes because never have to regen -; the page. - -(newsop vote (by for dir) - (let dir (saferead dir) - (if (isnt by user) - (pr "User mismatch.") - (aif (safe-item for) - (if (and (in dir 'up 'down) (canvote user it dir)) - (do (vote-for by it dir) - (logvote by it)) - (pr "Can't make that vote.")) - (pr "No such item."))))) + (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) - (tag (span id (string "score_" i!id)) - (pr i!score (plural i!score " point")))) - (byline i))) + (when (news-type i) (itemscore i user)) + (byline i user))) + +(def itemscore (i (o user)) + (tag (span id (string "score_" i!id)) + (pr (plural (if (is i!type 'pollopt) (realscore i) i!score) + "point"))) + (hook 'itemscore i user)) -(def byline (i) +; redefined later + +(def byline (i user) (pr " by ") - (link i!by (user-url i!by)) + (userlink user i!by) (pr " " (text-age:item-age i) " ")) (def user-url (user) (+ "user?id=" user)) -(def commentlink (i user) - (when (cansee user i) (pr bar*)) ; smells like a hack - (tag (a href (item-url i)) - (let n (- (len (visible user (family i))) 1) - (if (> n 0) - (pr n (plural n " comment")) - (pr "discuss"))))) +(= show-avg* nil) -(def family (i) (cons i (mappend family:item i!kids))) +(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 get!by (keep live (family i)))))))) (= user-changetime* 120 editor-changetime* 1440) @@ -944,18 +1217,91 @@ function vote(node) { (own-changeable-item user i))) (def own-changeable-item (user i) - (and (is user i!by) + (and (author user i) + (~mem 'locked i!keys) (no i!deleted) (or (everchange* i!type) (< (item-age i) user-changetime*)))) -(def editlink (story user) - (when (canedit user story) +(def editlink (i user) + (when (canedit user i) (pr bar*) - (link "edit" (edit-url story)))) + (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)))) + +(= 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 candelete (user story) - (or (admin user) (own-changeable-item user story))) +(def flaglink (i user whence) + (when (and user + (isnt user i!by) + (or (admin user) (> (karma user) flag-threshold*))) + (pr bar*) + (w/rlink (do (if (mem user i!flags) + (pull user i!flags) + (push user i!flags)) + (when (and (~mem 'nokill i!keys) + (len> i!flags flag-kill-threshold*) + (~find [admin _.2] i!vote)) + (kill i 'flags)) + whence) + (pr (if (mem user i!flags) "unflag" "flag"))) + (when (and (admin user) (len> i!flags many-flags*)) + (pr bar*) + (pr (plural (len i!flags) "flag") " ") + (w/rlink (do (if (mem 'nokill i!keys) + (pull 'nokill i!keys) + (push '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 "unkill" "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) + (pr (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 (ignored i!by)) + (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) @@ -995,19 +1341,19 @@ function vote(node) { (def permalink (story user) (when (cansee user story) (pr bar*) - (link "link" (item-url story)))) + (link "link" (item-url story!id)))) -(def logvote (user story) - (newslog user 'vote (story 'id) (list (story 'title)))) +(def logvote (ip user story) + (newslog ip user 'vote (story 'id) (list (story 'title)))) (def text-age (a) (tostring (if (>= a 1440) (let n (trunc (/ a 1440)) - (pr n (plural n " day") " ago")) + (pr (plural n "day") " ago")) (>= a 60) (let n (trunc (/ a 60)) - (pr n (plural n " hour") " ago")) + (pr (plural n "hour") " ago")) (let n (trunc a) - (pr n (plural n " minute") " ago"))))) + (pr (plural n "minute") " ago"))))) ; Voting @@ -1017,60 +1363,92 @@ function vote(node) { ; 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* 0) +(= 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 (uvar user ignore) + (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 ((votes* user) i!id) - (atwiths (ip (logins* user) - vote (list (seconds) ip user dir i!score)) - (unless (or (and (uvar user ignore) + (unless (or ((votes user) i!id) + (and (isnt user i!by) (~live i))) + (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)) - ; prevention of karma-bombing - (and (is dir 'down) - (or (and (~editor user) (just-downvoted user i!by)) - (uvar user nodowns))) - (and (no (legit-user user)) - (find [is (cadr _) ip] i!votes))) + (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))) (case dir up (++ i!score) down (-- i!score)) ; canvote protects against sockpuppet downvote of comments (when (and (is dir 'up) (possible-sockpuppet user)) (++ i!sockvotes)) - (if (storylike i) (adjust-rank i)) - ; get equal karma for comments - (unless (or (is user i!by) - (and (is ip i!ip) (~editor user))) + (if (metastory i) (adjust-rank i)) + (unless (or (author user i) + (and (is ip i!ip) (~editor user)) + (is i!type 'pollopt)) (case dir up (++ (karma i!by)) down (-- (karma i!by))) - (save-prof i!by))) + (save-prof i!by)) + (wipe (comment-cache* i!id))) + (if (admin user) (pushnew 'nokill i!keys)) (push vote i!votes) - (push (cons i!id vote) recent-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)))) + (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 use car, cadr to manipulate vote fields + +(def downvote-ratio (user (o sample 20)) + (let vs (keep (fn (x) + (let by ((item (car x)) 'by) + (nor (is by user) (ignored by)))) + (bestn sample (compare > car:cadr) (tablist (votes user)))) + (if vs + (/ (count [is ((cadr _) 3) 'down] vs) + (len vs)) + 0))) (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 (is ((item id) 'by) victim) (is dir 'down))) + (and (author victim (item id)) (is dir 'down))) prev)))) ; Ugly to pluck out fourth element. Should read votes into a vote @@ -1092,7 +1470,7 @@ function vote(node) { (login-page 'both "You have to be logged in to submit." (fn (user ip) (ensure-news-user user) - (newslog user 'submit-login ip) + (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)) @@ -1100,11 +1478,11 @@ function vote(node) { (pagemessage msg) (urform user req (process-story (get-user req) - (striptags (arg req "u")) + (clean-url (arg req "u")) (striptags (arg req "t")) showtext (and showtext (md-from-form (arg req "x") t)) - (req 'ip)) + req!ip) (tab (row "title" (input "t" title 50)) (if prefer-url* @@ -1118,7 +1496,7 @@ function vote(node) { (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 @@ -1133,17 +1511,24 @@ function vote(node) { (submit-page user u t) (submit-login-warning u t))) -(= title-limit* 100 - retry* "Please try again." - toolong* (string "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.") +(= title-limit* 80 + retry* "Please try again." + toolong* (string "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)) + (item-url it!id)) (if (no user) (flink [submit-login-warning url title showtext text]) (no (and (or (blank url) (valid-url url)) @@ -1153,34 +1538,108 @@ function vote(node) { (flink [submit-page user url title showtext text toolong*]) (and (blank url) (blank text)) (flink [submit-page user url title showtext text bothblank*]) - (atlet s (create-story url (scrubtitle title) text user ip) - (ban-test user s ip url url-kill* url-ignore*) - (when (uvar user ignore) (kill s)) - (push s!id (uvar user submitted)) - (save-prof user) - (vote-for user s) + (big-spamsites* (sitename url)) + (flink [msgpage user spammage*]) + (oversubmitting user ip 'story) + (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")))) -(= scrubrules* '(("Breaking: " "") ("Exclusive: " ""))) +(def submit-item (user i) + (push i!id (uvar user submitted)) + (save-prof user) + (vote-for user i)) -; Note that by deliberate tricks, someone could thus submit a story -; with a blank title. +; Turn this on when spam becomes a problem. -(def scrubtitle (str) (multisubst scrubrules* str)) +(= 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 (o kind 'story)) + (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)] 120) + (if (is kind 'story) + (if (ignored user) 0 1) + (if (ignored user) 2 10))))) + +; Note that by deliberate tricks, someone could submit a story with a +; blank title. + +(diskvar scrubrules* (+ newsdir* "scrubrules")) + +(def process-title (s) + (zap upcase (s 0)) + (multisubst scrubrules* s)) (def live-story-w/url (url) - (aand (url->story* url) (check it live))) + (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 (or (mem t1 multi-tld-countries*) + (and t3 (mem t2 long-domains*))) + (string t3 "." t2 "." t1) + (string t2 "." t1))))))) + +; Minor bug: can have both google.at and google.co.at. Same for jp. + +(= multi-tld-countries* '("uk" "jp" "au" "in" "ph" "tr" "za" "my" "nz" "br" + "mx" "th" "sg" "id" "pk" "eg" "il" "at" "pl")) + +(= long-domains* '("blogspot" "wordpress" "livejournal" "blogs" "typepad" + "weebly" "blog-city" + ; "sampasite" "multiply" "wetpaint" ; let's just try banning + "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 ; 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. -(= url-kill* nil - url-ignore* '("internetisseriousbusiness") - comment-kill* nil - comment-ignore* '("http://internetisseriousbusiness" - "http://www.internetisseriousbusiness") - ip-ban* nil) +(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. @@ -1188,87 +1647,225 @@ function vote(node) { ; 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 ban-test (user i ip string kill-list ignore-list) +(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)) + (when (caris ban 'ignore) + (set (ignored user)) + (save-prof user)) + (kill i 'banned-site))) + +(def ip-ban-test (i ip) + (when (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) - (assert (uvar user ignore)) + (set (ignored user)) (save-prof user)) - (when (or (mem ip ip-ban*) (some [posmatch _ string] kill-list)) - (kill i))) + (when (or (banned-ips* ip) (some [posmatch _ string] kill-list)) + (kill i 'banned))) + +; 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 killallby (user) (map kill (submissions user))) +(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) + (kill c 'thread) (map kill-whole-thread:item c!kids)) -; Could be stricter. -(def valid-url (url) - (and (len> url 10) - (begins url "http://") - (~find [in _ #\< #\> #\"] url))) +; Polls -(def parse-site (url) - (rev (tokens (cadr (tokens url [in _ #\/ #\?])) #\.))) +; 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) -(defmemo sitename (url) - (let toks (parse-site url) - (if (isa (saferead (car toks)) 'int) - (tostring (prall toks "" ".")) - (let (t1 t2 t3 . rest) toks - (if (or (mem t1 multi-tld-countries*) - (and t3 (mem t2 long-domains*))) - (string t3 "." t2 "." t1) - (string t2 "." t1)))))) +(= poll-threshold* 20) -; Minor bug: can have both google.at and google.co.at. Same for jp. +(newsop newpoll () + (if (and user (> (karma user) poll-threshold*)) + (newpoll-page user) + (pr "Sorry, you need at least " + 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)))))) -(= multi-tld-countries* '("uk" "jp" "au" "in" "ph" "tr" "za" "my" "nz" "br" - "mx" "th" "sg" "id" "pk" "eg" "il" "at")) +(def add-pollopt (user p text ip) + (unless (blank text) + (atlet o (create-pollopt p nil nil text user ip) + (= p!parts (+ p!parts (list o!id))) + (save-item p)))) -(= long-domains* '("blogspot" "wordpress" "livejournal" "blogs" "typepad" - "weebly" "blog-city" "com")) +(def display-pollopts (p user whence) + (each o (visible user (map item p!parts)) + (display-pollopt nil o user whence) + (spacerow 7))) -(def create-story (url title text user ip) - (newslog 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 (url->story* url) s) - (push s stories*) - s)) +(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) -(def item-url (story) (string "item?id=" (story 'id))) +(defmemo item-url (id) (string "item?id=" id)) (newsop item (id) (let s (safe-item id) (if (news-type s) - (item-page user s) - (pr "No such item.")))) + (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)))))) -(def news-type (s) - (and s (or (storylike s) (acomment s)))) +; 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)) - (shortpage user nil title here + here (item-url i!id)) + (shortpage user nil nil title here (tab (display-item nil i user here) (display-item-text i user) - (when (and (cansee user i) (live i) (commentable i)) + (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)))))) -(def commentable (i) (in i!type 'comment 'story)) +(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 i) + (commentable i) + (or (< (item-age i) commentable-threshold*) + (mem 'commentable i!keys)))) + (= displayfn* (table)) @@ -1278,6 +1875,11 @@ function vote(node) { (= (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)) @@ -1285,21 +1887,24 @@ function vote(node) { (aif i!parent (superparent:item it) i)) (def display-item-text (s user) - (when (and (cansee user s) (astory s) (blank s!url) (~blank s!text)) + (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 (story) (string "edit?id=" (story 'id))) +(def edit-url (i) (string "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) (is user i!by))) + (or (news-type i) (admin user) (author user i))) (edit-page user i) (pr "No such item.")))) @@ -1318,35 +1923,82 @@ function vote(node) { (int sockvotes ,(s 'sockvotes) ,e ,a) (yesno dead ,(s 'dead) ,e ,e) (yesno deleted ,(s 'deleted) ,a ,a) + (sexpr flags ,(s 'flags) ,a nil) + (sexpr keys ,(s 'keys) ,a ,a) (string ip ,(s 'ip) ,e nil))))) (= (fieldfn* 'comment) (fn (user s) (with (a (admin user) e (editor user) x (canedit user s)) `((mdtext text ,(s 'text) t ,x) + (int votes ,(len (s 'votes)) ,a nil) (int score ,(s 'score) t ,a) (int sockvotes ,(s 'sockvotes) ,e ,a) (yesno dead ,(s 'dead) ,e ,e) (yesno deleted ,(s 'deleted) ,a ,a) + (sexpr flags ,(s 'flags) ,a nil) + (sexpr keys ,(s 'keys) ,a ,a) + (string ip ,(s 'ip) ,e nil))))) + +(= (fieldfn* 'poll) + (fn (user s) + (with (a (admin user) e (editor user) x (canedit user s)) + `((string1 title ,(s 'title) t ,x) + (mdtext2 text ,(s 'text) t ,x) + (int votes ,(len (s 'votes)) ,a nil) + (int score ,(s 'score) t ,a) + (int sockvotes ,(s 'sockvotes) ,e ,a) + (yesno dead ,(s 'dead) ,e ,e) + (yesno deleted ,(s 'deleted) ,a ,a) + (sexpr flags ,(s 'flags) ,a nil) + (sexpr keys ,(s 'keys) ,a ,a) + (string ip ,(s 'ip) ,e nil))))) + +(= (fieldfn* 'pollopt) + (fn (user s) + (with (a (admin user) e (editor user) x (canedit user s)) + `((string title ,(s 'title) t ,x) + (url url ,(s 'url) t ,x) + (mdtext2 text ,(s 'text) t ,x) + (int votes ,(len (s 'votes)) ,a nil) + (int score ,(s 'score) t ,a) + (int sockvotes ,(s 'sockvotes) ,e ,a) + (yesno dead ,(s 'dead) ,e ,e) + (yesno deleted ,(s 'deleted) ,a ,a) + (sexpr flags ,(s 'flags) ,a nil) + (sexpr keys ,(s 'keys) ,a ,a) (string ip ,(s '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 s) - (let here (edit-url s) - (shortpage user nil "Edit" here - (tab (display-item nil s user here) - (display-item-text s user)) +(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* s!type) user s) - (fn (name val) (= (s name) val)) - (fn () (save-item s) - (if (storylike s) (adjust-rank s)) - (edit-page user s))) - (hook 'edit user s)))) + ((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) + (if (metastory i) (adjust-rank i)) + (wipe (comment-cache* i!id)) + (edit-page user i))) + (hook 'edit user i)))) + +(def ignore-edit (user i name val) + (or (and (is name 'title) + (len> val title-limit*)) + (and (is name 'dead) + (mem 'nokill i!keys) + (~admin user)))) ; Comment Submission @@ -1355,7 +2007,7 @@ function vote(node) { (login-page 'both "You have to be logged in to comment." (fn (u ip) (ensure-news-user u) - (newslog u 'comment-login ip) + (newslog ip u 'comment-login) (addcomment-page parent u whence text)))) (def addcomment-page (parent user whence (o text) (o msg)) @@ -1367,13 +2019,25 @@ function vote(node) { (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)) - (urform user req - (process-comment (get-user req) parent (arg req "text") (req 'ip) whence) - (textarea "text" 6 60 + (timed-arform 1800 + (fn (req) + (when-umatch/r user req + (process-comment (get-user req) 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 (astory parent) "add comment" "reply")))) + (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 @@ -1384,16 +2048,17 @@ function vote(node) { (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) - (ban-test user c ip text comment-kill* comment-ignore*) - (when (uvar user ignore) (kill c)) - (push c!id (uvar user submitted)) - (save-prof user) - (vote-for user c) + (comment-ban-test user c ip text comment-kill* comment-ignore*) + (when (or (ignored user) (< (karma user) comment-threshold*)) + (kill c 'ignored/karma)) + (submit-item user c) whence))) (def create-comment (parent text user ip) - (newslog user 'comment (parent 'id)) + (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) @@ -1409,7 +2074,7 @@ function vote(node) { (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 40)))) + (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)))) @@ -1423,88 +2088,193 @@ function vote(node) { (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))) + (when astree (td (hspace (* indent 40)))) (tag (td valign 'top) (votelinks c user whence t)) - (tag (td class 'default) - (let parent (and (or (no astree) showpar) (c 'parent)) - (spanclass comhead - (itemline c user) - (permalink c user) - (when parent - (when (cansee user c) (pr bar*)) - (link "parent" (item-url (item parent)))) - (editlink c user) - (deletelink c user whence) - (deadmark c user) - (when showon - (pr " | on: ") - (let s (superparent c) - (link (ellipsize s!title 50) - (if (empty s!url) (item-url s) s!url))))) - (when (or parent (cansee user c)) - (br) (vspace 20)) - (spanclass comment - (if (no (cansee user c)) - (pr (pseudo-text c)) - (and (no (live c)) (isnt user c!by)) - (spanclass dead (pr c!text)) - (tag (font color (comment-color c)) - (pr c!text)))) - (when (and astree (cansee user c) (live c)) - (para) - (tag (font size 1) - (underline (replylink c user whence)))))))) - -(def replylink (i user whence (o title 'reply)) - (linkf title (req) - (let user (get-user req) - (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 u 'comment-login ip) - (addcomment-page i u whence))))))) + (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) + (when (admin 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 (string "reply?id=" i!id "&whence=" (urlencode whence)))) + +(newsop reply (id whence) + (with (i (safe-item id) + whence (if whence (urldecode whence) "news")) + (if (and i (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) - (let s (realscore c) - (if (> s 0) black - (< s -2) (gray 150) - (case s -2 (gray 130) -1 (gray 90) 0 (gray 50))))) + (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) (string "threads?id=" user)) +(def threads-url (user) (+ "threads?id=" user)) -(newsop threads (id) (threads-page user id)) +(newsop threads (id) + (if id + (threads-page user id) + (pr "No user specified."))) (def threads-page (user subject) - (if (profs* subject) - (withs (title (string subject "'s comments") + (if (profile subject) + (withs (title (+ subject "'s comments") label (if (is user subject) "threads" title) here (threads-url subject)) - (longpage user (msec) label title here + (longpage user (msec) nil label title here (awhen (keep [and (cansee user _) (no (subcomment _))] - (comments subject perpage*)) - (tab (each c it - (display-comment-tree c user here 0 t)))))) + (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 + (let n start + (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) + (moreclink comments label title end newend)))))))))) + +; Identical to morelink except missing number arg and +; display-items -> display-threads. Try to unify. + +(def moreclink (comments label title end newend) + (tag (a href (url-for + (afnid (fn (req) + (prn) + (let user (get-user req) + (newslog req!ip user 'more label) + (longpage user (msec) nil label title (url-for it) + (display-threads user comments + label title (url-for it) + end newend)))))) + rel 'nofollow) + (pr "More"))) + (def submissions (user (o limit)) (map item (firstn limit (uvar user submitted)))) -(def comments (user (o limit)) - ((afn (ids count) - (if (or (no ids) (is count limit)) - nil - (let c (item (car ids)) - (consif (and (acomment c) c) - (self (cdr ids) - (+ count (if (acomment c) 1 0))))))) - (uvar user submitted) 0)) - +(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))) @@ -1517,19 +2287,22 @@ function vote(node) { ; Submitted -(def submitted-url (user) (string "submitted?id=" user)) +(def submitted-url (user) (+ "submitted?id=" user)) -(newsop submitted (id) (submitted-page user id)) +(newsop submitted (id) + (if id + (submitted-page user id) + (pr "No user specified."))) (def submitted-page (user subject) - (if (profs* subject) - (with (label (string subject "'s submissions") + (if (profile subject) + (with (label (+ subject "'s submissions") here (submitted-url subject)) - (longpage user (msec) label label here - (if (or (no (uvar subject ignore)) + (longpage user (msec) nil label label here + (if (or (no (ignored subject)) (is user subject) (seesdead user)) - (aif (keep [and (astory _) (cansee user _)] + (aif (keep [and (metastory _) (cansee user _)] (submissions subject)) (display-items user it label label here 0 perpage* t))))) (pr "No such user."))) @@ -1540,7 +2313,7 @@ function vote(node) { (newsop rss () (rsspage nil)) (newscache rsspage user 90 - (rss-stories (firstn 25 ranked-stories*))) + (rss-stories (retrieve perpage* live ranked-stories*))) (def rss-stories (stories) (tag (rss version "2.0") @@ -1550,7 +2323,7 @@ function vote(node) { (tag description (pr site-desc*)) (each s stories (tag item - (let comurl (+ site-url* (item-url s)) + (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)) @@ -1564,25 +2337,64 @@ function vote(node) { (= nleaders* 20) -(newscache leaderspage user 180 - (longpage user (msec) "leaders" "Leaders" "leaders" - (zerotable +(newscache leaderspage user 1000 + (longpage user (msec) nil "leaders" "Leaders" "leaders" + (sptab (let i 0 (each u (firstn nleaders* (leading-users)) - (tr (tdright (pr (++ i) ".")) - (td (hspace 7)) - (td (underlink u (user-url u))) - (td (hspace 10)) - (tdright (pr (karma u)))) + (tr (tdr (pr (++ i) ".")) + (td (userlink user u nil)) + (tdr (pr (karma u))) + (when (admin user) + (tdr (aif (uvar u avg) (pr (num it 2 t t)))))) (if (is i 10) (spacerow 30))))))) +(= leader-threshold* 1) ; redefined later + (def leading-users () (sort (compare > [karma _]) - (users [and (> (karma _) 1) (~admin _)]))) + (users [and (> (karma _) leader-threshold*) (~admin _)]))) (adop editors () (tab (each u (users [is (uvar _ auth) 1]) - (row (link u (user-url u)))))) + (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)) + (let u (rand-key profs*) + (if (test u) u (rand-user test)))) + +; maybe promote to arc.arc + +(def rand-key (h) + (if (empty h) + nil + (let n (rand (len h)) + (catch + (ontable k v h + (when (is (-- n) -1) + (throw k))))))) + +; 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 get!score (rem get!deleted it))))) + nil)) ; Comment Analysis @@ -1593,8 +2405,8 @@ function vote(node) { (newsop active () (active-page user)) -(newscache active-page user 90 - (listpage user (msec) (actives user) "active" "Active Threads" "active" t)) +(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)))) @@ -1602,23 +2414,23 @@ function vote(node) { (= active-threshold* 1500) (def active-rank (s) - (apply + (map [max 0 (- active-threshold* (item-age _))] - (cdr (family 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")) + "comments" "New Comments" "newcomments" nil)) ; Doc (defop formatdoc req - (minipage "Formatting Options" - (spanclass admin - (center (widtable 500 formatdoc*))))) + (msgpage (get-user req) formatdoc* "Formatting Options")) (= formatdoc-url* "formatdoc") @@ -1655,11 +2467,11 @@ first asterisk isn't whitespace. (def procrast-msg (user whence) (let m (+ 1 (trunc (- (uvar user minaway) - (/ (since (uvar user lastview)) 60)))) + (minutes-since (uvar user lastview))))) (pr "<b>Get back to work!</b>") (para "Sorry, you can't see this page. Based on the anti-procrastination parameters you set in your profile, you'll be able to use the site - again in " m (plural m " minute") ".") + 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 @@ -1668,9 +2480,8 @@ first asterisk isn't whitespace. minutes, with <tt>minaway</tt> minutes between them.") (para) (w/rlink whence (underline (pr "retry"))) - (hspace 20) - (w/rlink (do (reset-procrast user) whence) - (underline (pr "override"))) + ; (hspace 20) + ; (w/rlink (do (reset-procrast user) whence) (underline (pr "override"))) (br2))) @@ -1682,7 +2493,7 @@ first asterisk isn't whitespace. (minipage "Reset Password" (if msg (pr msg) - ((orf no blank) (uvar user email)) + (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 @@ -1699,48 +2510,181 @@ first asterisk isn't whitespace. (newspage user)))) +; Scrubrules + +(defopa scrubrules req + (scrubrules-page (get-user req) scrubrules*)) + +; If have other global alists, generalize an alist edit page. +; Or better still generalize vars-form. + +(def scrubrules-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)) + (scrubrules-page user scrubrules* "Changes saved.")) + (scrubrules-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)) + (prn) + (apply pr (intersperse #\newline (map car rules)))) + (pr " To: ") + (tag (textarea name 'to + cols (apply max 20 (map len (map cadr rules))) + rows (+ (len rules) 3)) + (prn) + (apply pr (intersperse #\newline (map cadr rules)))) + (br2) + (submit "update")))) + + ; Abuse Analysis +(adop badsites () + (with (banned (banned-site-items) + offgray (gray 220)) + (sptab + (row "Dead" "Days" "Site" "O" "K" "I" "Users") + (each (site deads) (let pairs (killedsites) + (+ pairs (map [list _ (banned _)] + (rem (fn (d) + (some [caris _ d] pairs)) + (keys banned-sites*))))) + (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 (banned-sites* site) offgray black) + (pr "x")))) + (td (w/rlink (do (set-site-ban user site 'kill) "badsites") + (fontcolor (if (caris (banned-sites* site) 'kill) + darkred + offgray) + (pr "x")))) + (td (w/rlink (do (set-site-ban user site 'ignore) "badsites") + (fontcolor (if (caris (banned-sites* site) 'ignore) + darkred + offgray) + (pr "x")))) + (td (each u (dedup (map get!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 (bads it)))) + (with (acc nil deadcount (table)) + (ontable 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 + (let bads (table) + (each-loaded-item i + (awhen (and i!dead (sitename i!url)) + (when (banned-sites* it) + (push i (bads it))))) + bads)) + +; 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 () - (let (bads goods) (badips) - (tab - (row "IP" "Dead" "Live") - (each ip (sort (compare > (memo [len (bads _)])) - (rem [len< (bads _) 3] (keys bads))) - (tr (td ip) - (tdright - (w/link (listpage user (msec) (bads ip) - (string "dead from " ip) nil "badips" t) - (pr (len (bads ip))))) - (tdright - (w/link (listpage user (msec) (goods ip) - (string "live from " ip) nil "badips" t) - (pr (len (goods ip)))))))))) - -; Sort by time, instead of putting stories before comments? - -(def 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") + (tag-if banned (font color 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 s (+ stories* comments*) - (if (s 'dead) - (push s (bads (s 'ip))) - (push s (goods (s 'ip))))) + (each-loaded-item s + (if (and s!dead (commentable s)) + (push s (bads s!ip)) + (push s (goods s!ip)))) (ontable k v bads (zap rev (bads k))) (ontable k v goods (zap rev (goods k))) (list bads goods))) -(adop killed () - (let deads (fn (items) (firstn maxend* (keep [_ 'dead] items))) - (display-items user (deads stories*) nil nil "killed") - (vspace 35) - (color-stripe textgray) - (vspace 35) - (display-items user (deads comments*) nil nil "killed"))) +(def sorted-badips (bads goods) + (with (ips (let ips (rem [len< (bads _) 2] (keys bads)) + (+ ips (rem [mem _ ips] (keys banned-ips*)))) + subs (table)) + (each ip ips + (= (subs ip) (dedup (map get!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 () - (sptab (each user (sort (compare > [uvar _ created]) - (users [uvar _ ignore])) - (row (link user (user-url user)))))) + (tab (each u (sort (compare > [uvar _ created]) + (users [ignored _])) + (row (userlink user u nil))))) (adop badlogins () (logins-page bad-logins*)) @@ -1754,16 +2698,22 @@ first asterisk isn't whitespace. ; Stats (adop optimes () - (sptab (each name (sort < newsop-names*) - (tr (td name) - (td (hspace 10)) - (tdright (pr (aand (qlist (optimes* name)) - (num (avg it) 2 t)))))))) + (sptab + (tr (td "op") (tdr "avg") (tdr "med") (tdr "req") (tdr "total")) + (spacerow 10) + (each name (sort < newsop-names*) + (tr (td name) + (let ms (aand (qlist (optimes* name)) (avg it)) + (tdr (pr (if ms (round ms) ""))) + (tdr (pr (aif (qlist (optimes* name)) (med it) ""))) + (let n (opcounts* name) + (tdr (pr (or n ""))) + (tdr (pr (if n (round (/ (* n ms) 1000)) ""))))))))) (defop topcolors req (minipage "Custom Colors" (tab - (each c (dedup (map downcase (trues [uvar _ topcolor] (keys profs*)))) + (each c (dedup (map downcase (trues [uvar _ topcolor] (users)))) (tr (td c) (tdcolor (hex>color c) (hspace 30))))))) news.arc @@ -21,10 +21,10 @@ (tag (table border 0 cellspacing 10) (each app (dir (+ appdir* user)) (tr (td app) - (td (userlink user 'edit (edit-app user app))) - (td (userlink user 'run (run-app user app))) + (td (ulink user 'edit (edit-app user app))) + (td (ulink user 'run (run-app user app))) (td (hspace 40) - (userlink user 'delete (rem-app user app)))))) + (ulink user 'delete (rem-app user app)))))) (br2) (aform (fn (req) (when-umatch user req @@ -39,7 +39,7 @@ (def read-app (user app) (aand (app-path user app) (file-exists it) - (w/infile i it (readall i)))) + (readfile it))) (def write-app (user app exprs) (awhen (app-path user app) prompt.arc @@ -1,31 +1,28 @@ ; HTTP Server. -; could 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. - ; if you want to be able to ^C the server, set breaksrv* to t -(= arcdir* "arc/" logdir* "arc/logs/" quitsrv* nil breaksrv* nil) +(= 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 (prn "ready to serve port " port) + (flushout) (= currsock* s) (until quitsrv* - (if breaksrv* - (handle-request s) - (errsafe (handle-request s))))) + (handle-request s breaksrv*))) (prn "quit server")) (def serve1 ((o port 8080)) - (w/socket s port (handle-request s))) + (w/socket s port (handle-request s t))) (def ensure-srvdirs () - (ensure-dir arcdir*) - (ensure-dir logdir*)) + (map ensure-dir (list arcdir* logdir* staticdir*))) (= srv-noisy* nil) @@ -39,41 +36,72 @@ ; to handle it. also arrange to kill that thread if it ; has not completed in threadlife* seconds. -(= srvthreads* nil threadlimit* 50 threadlife* 30) - -; Could auto-throttle ips, e.g. if one has more than x% of recent requests. - -(= requests* 0 requests/ip* (table) throttle-ips* (table) throttle-time* 30) - -(def handle-request (s (o life threadlife*)) - (if (len< (pull dead srvthreads*) threadlimit*) - (let (i o ip) (socket-accept s) - (++ requests*) - (= (requests/ip* ip) (+ 1 (or (requests/ip* ip) 0))) - (let th (thread - (if (throttle-ips* ip) (sleep (rand throttle-time*))) - (handle-request-thread i o ip)) - (push th srvthreads*) - (thread (sleep life) - (unless (dead th) (prn "srv thread took too long")) - (break-thread th) - (close i o)))) - (sleep .2))) +(= 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 + (errsafe (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* 20 dos-window* 3) + +(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) + (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)) - (srvlog 'srv ip type op cooks) - (case type - get (respond o op args cooks ip) - post (handle-post i o op n cooks ip) - (respond-err o "Unknown request: " (car lines))) - (assert responded)) + (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) @@ -82,10 +110,22 @@ (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 n cooks ip) +(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.") @@ -95,7 +135,7 @@ (-- n) (push c line)) (if srv-noisy* (pr "\n\n")) - (respond o op (parseargs (string (rev line))) cooks ip)))) + (respond o op (+ (parseargs (string (rev line))) args) cooks ip)))) (= header* "HTTP/1.0 200 OK Content-Type: text/html; charset=utf-8 @@ -103,26 +143,27 @@ Connection: close") (= srv-header* (table)) -(= (srv-header* 'gif) -"HTTP/1.0 200 OK -Content-Type: image/gif -Connection: close") +(def gen-srv-header (ctype) + (+ "HTTP/1.0 200 OK +Content-Type: " + ctype + " +Connection: close")) -(= (srv-header* 'jpg) -"HTTP/1.0 200 OK -Content-Type: image/jpeg -Connection: close") - -(= (srv-header* 'text/html) -"HTTP/1.0 200 OK -Content-Type: text/html; charset=utf-8 -Connection: close") +(map (fn ((k v)) (= (srv-header* k) (gen-srv-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)) +(= 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)) @@ -143,14 +184,15 @@ Connection: close") (mac defop (name parm . body) (w/uniq gs - `(defop-raw ,name (,gs ,parm) - (w/stdout ,gs (prn) ,@body)))) + `(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 (assert (redirector* ',name)) + `(do (set (redirector* ',name)) (defop-raw ,name (,gs ,parm) ,@body)))) @@ -161,41 +203,40 @@ Connection: close") cooks nil ip nil) -(= unknown-msg* "Unknown operator.") +(= unknown-msg* "Unknown.") (def respond (str op args cooks ip) (w/stdout str (aif (srvops* op) - (let req (inst 'request 'args args 'cooks cooks 'ip ip) - (if (redirector* op) - (do (prn rdheader*) - (prn "Location: " (it str req)) - (prn)) - (do (prn header*) - (it str req)))) - (static-filetype op) - (do (prn (srv-header* it)) - (prn) - (w/infile i (string op) - (whilet b (readb i) - (writeb b str)))) - (respond-err str unknown-msg*)))) - -(def gifname (sym) - (let str (string sym) - (and (endmatch ".gif" str) (~find #\/ str)))) - -; Exclude arc, or anyone can see source. Need to use a separate dir. + (let req (inst 'request 'args args 'cooks cooks 'ip ip) + (if (redirector* op) + (do (prn rdheader*) + (prn "Location: " (it str req)) + (prn)) + (do (prn header*) + (it str req)))) + (let filetype (static-filetype op) + (aif (and filetype (file-exists (string staticdir* op))) + (do (prn (srv-header* filetype)) + (prn) + (w/infile i it + (whilet b (readb i) + (writeb b str)))) + (respond-err str unknown-msg*)))))) (def static-filetype (sym) - (let fname (string sym) + (let fname (coerce sym 'string) (and (~find #\/ fname) - (case (last (check (tokens fname #\.) ~single)) + (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) @@ -212,7 +253,7 @@ Connection: close") (and (is type 'post) (some (fn (s) (and (begins s "Content-Length:") - (coerce (cadr (tokens s)) 'int))) + (errsafe:coerce (cadr (tokens s)) 'int))) (cdr lines))) (some (fn (s) (and (begins s "Cookie:") @@ -240,13 +281,13 @@ Connection: close") (map [tokens _ #\=] (cdr (tokens s [or (whitec _) (is _ #\;)])))) -(def arg (req key) (alref (req 'args) key)) +(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) + (aif req!args (apply string "?" (intersperse '& (map (fn ((k v)) (string k '= v)) @@ -292,7 +333,7 @@ Connection: close") ; 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 20000)) +(def harvest-fnids ((o n 50000)) ; was 20000 (when (len> fns* n) (pull (fn ((id created lasts)) (when (> (since created) lasts) @@ -357,6 +398,9 @@ Connection: close") (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) @@ -377,6 +421,12 @@ Connection: close") (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? @@ -388,6 +438,14 @@ Connection: close") (,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). @@ -399,11 +457,28 @@ Connection: close") (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf))) ,@body)))) +(mac timed-aform2 (genurl 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)) +; these timed- variants are overlong + +(mac timed-arform (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)) @@ -425,15 +500,18 @@ Connection: close") (= (unique-ids* id) id)))) (def srvlog (type . args) - (w/appendfile o (string logdir* type "-" (memodate)) - (w/stdout o (apply prs (seconds) args) (prn)))) + (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 (date)) + (= lastasked now lastval (datestring)) lastval))) ) @@ -455,8 +533,44 @@ Connection: close") (let n (requests/ip* ip) (row ip n (pr (num (* 100 (/ n requests*)) 1))))))))) -(def ttest (ip) - (let n (requests/ip* ip) - (list ip n (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. srv.arc @@ -8,13 +8,41 @@ ;"\u0085" (def tokens (s (o sep whitec)) - (let test (if (isa sep 'fn) sep (fn (c) (is c sep))) + (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))))))) + (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))))) ; > (require (lib "uri-codec.ss" "net")) ;> (form-urlencoded-decode "x%ce%bbx") @@ -30,12 +58,18 @@ (caselet c (s i) #\+ (writec #\space) #\% (do (when (> (- (len s) i) 2) - (let code (coerce (cut s (+ i 1) (+ i 3)) - 'int 16) - (writeb code))) + (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) @@ -69,7 +103,7 @@ (if (isa pat 'fn) (for i start (- (len seq) 1) (when (pat (seq i)) (throw i))) - (for i start (- (len seq) (- (len pat) 2)) + (for i start (- (len seq) (len pat)) (when (headmatch pat seq i) (throw i)))) nil)) @@ -113,6 +147,8 @@ (def blank (s) (~find ~whitec s)) +(def nonblank (s) (unless (blank s) s)) + (def trim (s where (o test whitec)) (withs (f (testify test) p1 (pos ~f s)) @@ -126,40 +162,52 @@ (+ i 1)))) ""))) -(def num (m (o digits 2) (o trail-zeros nil) (o init-zero nil)) - (let comma - (fn (i) - (tostring - (map [apply pr (rev _)] - (rev (intersperse '(#\,) - (tuples (rev (coerce (string i) 'cons)) - 3)))))) - (if (< digits 1) - (comma (roundup m)) - (exact m) - (string (comma m) - (when (and trail-zeros (> digits 0)) - (string "." (newstring digits #\0)))) - (withs (d (expt 10 digits) - n (/ (roundup (* m d)) d) - i (trunc n)) - (+ (if (is i 0) (if init-zero "0" "") (comma i)) - (withs (rest (string (abs (trunc (- (* n d) (* i d))))) - padded (+ (newstring (- digits (len rest)) #\0) - rest) - final (if trail-zeros - padded - (trim padded 'end [is _ #\0]))) - (string (unless (empty final) ".") - final))))))) +(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 plural (n str) +(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 strings.arc 81576aed622d560fdb3c96a26bb56691b1b9aa9c Michael Arntzenius daekharel@gmail.com http://github.com/nex3/arc/commit/9f2e1dd53b5b66bb4d65a33d09d403f1a656f8f6 9f2e1dd53b5b66bb4d65a33d09d403f1a656f8f6 2009-05-31T09:10:47-07:00 2009-05-31T09:10:47-07:00 arc3.tar 6e28d9da40724408c8cda1368863d1931b3bae97 Michael Arntzenius daekharel@gmail.com