arc0 vs arc3.1
lines with < are in arc0, aren't in arc3.1
lines with > aren't in arc0, are in arc3.1
lines with ========... are 80 chars wide
================================================================================
ac.scm
================================================================================
2 < ; scheme48
3 < ; ,open tables sockets extended-ports c-system-function ascii i/o-internal
4 < ; ,open posix-files handle random pp simple-conditions
5 <
6 < ; to do:
7 < ; select, perhaps with threads, or pltt events
8 < ; check argument count for complex arguments
2 > ; Arc Compiler.
9 3
10 < ; refs.arc, first 300 lines of x, total CPU time including startup. on powerbook.
11 < ; scheme48: 31.944u 0.518s 2:13.65 24.2% 0+0k 5+7io 0pf+0w
12 < ; mzscheme: 16.425u 0.489s 0:52.61 32.1% 0+0k 26+22io 0pf+0w
13 <
14 < ; dynamic creation of local variables with =
15 < ; can you create globals inside a procedure?
16 < ; does action of = depend on whether, at run time,
17 < ; the variable has a global definition?
18 < ; what's the scope of such a variable?
19 < ; though a.lisp seems to create a global, not a local!
20 < ; run-time expansion of macros
21 < ; how do I know if something is a macro at compile time?
22 < ; macros have lexical scope. so how do i know if a lexical
23 < ; variable is going to be bound to a procedure? or to a macro?
24 < ; what is annotate doing to symbols?
25 < ; tests.arc implies that '(a b) produces a mutable list
26 < ; so (fn () '(a)) produces a list that can be modified,
27 < ; and future calls will reflect the modifications
28 < ; oy. clisp works this way too.
29 < ; it's not that easy to simulate this.
30 < ; what is this? (def foo1 (x (o y x)) (list x y))
31 <
32 < ; it's not clear I translate NILs in the outputs of macros correctly.
33 < ; I translate (NIL . NIL) to ('NIL . '())
34 < ; I use Scheme apply to call macros.
35 < ; Scheme apply demands a '()-terminated list.
36 < ; most macros have a . body argument.
37 < ; so body is '()-terminated, not NIL-terminated.
38 < ; solution: ar-false? knows about '()
39 < ; this doesn't work, since var isn't a variable name:
40 < ; (mac or args
41 < ; (and args
42 < ; (let var (tag 'symbol (list 'or))
43 < ; (list 'let var (car args)
44 < ; (list 'if var var (cons 'or (cdr args)))))))
45 <
46 4 (module ac mzscheme
47 5
48 6 (provide (all-defined))
49 7 (require (lib "port.ss"))
50 8 (require (lib "process.ss"))
51 9 (require (lib "pretty.ss"))
10 > (require (lib "foreign.ss"))
11 > (unsafe!)
52 12
53 13 ; compile an Arc expression into a Scheme expression,
54 14 ; both represented as s-expressions.
55 15 ; env is a list of lexically bound variables, which we
56 16 ; need in order to decide whether set should create a global.
57 17
58 18 (define (ac s env)
59 < (cond ((string? s) (string-copy s)) ; to avoid immutable strings
19 > (cond ((string? s) (ac-string s env))
60 20 ((literal? s) s)
61 21 ((eqv? s 'nil) (list 'quote 'nil))
62 22 ((ssyntax? s) (ac (expand-ssyntax s) env))
63 23 ((symbol? s) (ac-var-ref s env))
64 24 ((ssyntax? (xcar s)) (ac (cons (expand-ssyntax (car s)) (cdr s)) env))
65 25 ((eq? (xcar s) 'quote) (list 'quote (ac-niltree (cadr s))))
66 26 ((eq? (xcar s) 'quasiquote) (ac-qq (cadr s) env))
67 27 ((eq? (xcar s) 'if) (ac-if (cdr s) env))
68 28 ((eq? (xcar s) 'fn) (ac-fn (cadr s) (cddr s) env))
69 < ((eq? (xcar s) 'set) (ac-set (cdr s) env))
70 < ; this line could be removed without changing semantics
29 > ((eq? (xcar s) 'assign) (ac-set (cdr s) env))
30 > ; the next three clauses could be removed without changing semantics
31 > ; ... except that they work for macros (so prob should do this for
32 > ; every elt of s, not just the car)
71 33 ((eq? (xcar (xcar s)) 'compose) (ac (decompose (cdar s) (cdr s)) env))
34 > ((eq? (xcar (xcar s)) 'complement)
35 > (ac (list 'no (cons (cadar s) (cdr s))) env))
36 > ((eq? (xcar (xcar s)) 'andf) (ac-andf s env))
72 37 ((pair? s) (ac-call (car s) (cdr s) env))
73 38 (#t (err "Bad object in expression" s))))
39 >
40 > (define atstrings #f)
41 >
42 > (define (ac-string s env)
43 > (if atstrings
44 > (if (atpos s 0)
45 > (ac (cons 'string (map (lambda (x)
46 > (if (string? x)
47 > (unescape-ats x)
48 > x))
49 > (codestring s)))
50 > env)
51 > (unescape-ats s))
52 > (string-copy s))) ; avoid immutable strings
74 53
75 54 (define (literal? x)
76 55 (or (boolean? x)
77 56 (char? x)
78 57 (string? x)
79 58 (number? x)
80 59 (eq? x '())))
81 60
82 61 (define (ssyntax? x)
83 62 (and (symbol? x)
84 < (not (or (eqv? x '+) (eqv? x '++)))
63 > (not (or (eqv? x '+) (eqv? x '++) (eqv? x '_)))
85 64 (let ((name (symbol->string x)))
86 65 (has-ssyntax-char? name (- (string-length name) 1)))))
87 66
88 67 (define (has-ssyntax-char? string i)
89 68 (and (>= i 0)
90 69 (or (let ((c (string-ref string i)))
91 < (or (eqv? c #\:) (eqv? c #\~)))
70 > (or (eqv? c #\:) (eqv? c #\~)
71 > (eqv? c #\&)
72 > ;(eqv? c #\_)
73 > (eqv? c #\.) (eqv? c #\!)))
92 74 (has-ssyntax-char? string (- i 1)))))
93 75
94 76 (define (read-from-string str)
95 77 (let ((port (open-input-string str)))
96 78 (let ((val (read port)))
97 79 (close-input-port port)
98 80 val)))
99 81
82 > ; Though graphically the right choice, can't use _ for currying
83 > ; because then _!foo becomes a function. Maybe use <>. For now
84 > ; leave this off and see how often it would have been useful.
85 >
86 > ; Might want to make ~ have less precedence than &, because
87 > ; ~foo&bar prob should mean (andf (complement foo) bar), not
88 > ; (complement (andf foo bar)).
89 >
100 90 (define (expand-ssyntax sym)
91 > ((cond ((or (insym? #\: sym) (insym? #\~ sym)) expand-compose)
92 > ((or (insym? #\. sym) (insym? #\! sym)) expand-sexpr)
93 > ((insym? #\& sym) expand-and)
94 > ; ((insym? #\_ sym) expand-curry)
95 > (#t (error "Unknown ssyntax" sym)))
96 > sym))
97 >
98 > (define (expand-compose sym)
101 99 (let ((elts (map (lambda (tok)
102 100 (if (eqv? (car tok) #\~)
103 < `(complement ,(chars->value (cdr tok)))
101 > (if (null? (cdr tok))
102 > 'no
103 > `(complement ,(chars->value (cdr tok))))
104 104 (chars->value tok)))
105 < (tokens #\: (symbol->chars sym) '() '()))))
105 > (tokens (lambda (c) (eqv? c #\:))
106 > (symbol->chars sym)
107 > '()
108 > '()
109 > #f))))
106 110 (if (null? (cdr elts))
107 111 (car elts)
108 112 (cons 'compose elts))))
109 113
114 > (define (expand-and sym)
115 > (let ((elts (map chars->value
116 > (tokens (lambda (c) (eqv? c #\&))
117 > (symbol->chars sym)
118 > '()
119 > '()
120 > #f))))
121 > (if (null? (cdr elts))
122 > (car elts)
123 > (cons 'andf elts))))
124 >
125 > ; How to include quoted arguments? Can't treat all as quoted, because
126 > ; never want to quote fn given as first. Do we want to allow quote chars
127 > ; within symbols? Could be ugly.
128 >
129 > ; If release, fix the fact that this simply uses v0... as vars. Should
130 > ; make these vars gensyms.
131 >
132 > (define (expand-curry sym)
133 > (let ((expr (exc (map (lambda (x)
134 > (if (pair? x) (chars->value x) x))
135 > (tokens (lambda (c) (eqv? c #\_))
136 > (symbol->chars sym)
137 > '()
138 > '()
139 > #t))
140 > 0)))
141 > (list 'fn
142 > (keep (lambda (s)
143 > (and (symbol? s)
144 > (eqv? (string-ref (symbol->string s) 0)
145 > #\v)))
146 > expr)
147 > expr)))
148 >
149 > (define (keep f xs)
150 > (cond ((null? xs) '())
151 > ((f (car xs)) (cons (car xs) (keep f (cdr xs))))
152 > (#t (keep f (cdr xs)))))
153 >
154 > (define (exc elts n)
155 > (cond ((null? elts)
156 > '())
157 > ((eqv? (car elts) #\_)
158 > (cons (string->symbol (string-append "v" (number->string n)))
159 > (exc (cdr elts) (+ n 1))))
160 > (#t
161 > (cons (car elts) (exc (cdr elts) n)))))
162 >
163 > (define (expand-sexpr sym)
164 > (build-sexpr (reverse (tokens (lambda (c) (or (eqv? c #\.) (eqv? c #\!)))
165 > (symbol->chars sym)
166 > '()
167 > '()
168 > #t))
169 > sym))
170 >
171 > (define (build-sexpr toks orig)
172 > (cond ((null? toks)
173 > 'get)
174 > ((null? (cdr toks))
175 > (chars->value (car toks)))
176 > (#t
177 > (list (build-sexpr (cddr toks) orig)
178 > (if (eqv? (cadr toks) #\!)
179 > (list 'quote (chars->value (car toks)))
180 > (if (or (eqv? (car toks) #\.) (eqv? (car toks) #\!))
181 > (err "Bad ssyntax" orig)
182 > (chars->value (car toks))))))))
183 >
184 > (define (insym? char sym) (member char (symbol->chars sym)))
185 >
110 186 (define (symbol->chars x) (string->list (symbol->string x)))
111 187
112 188 (define (chars->value chars) (read-from-string (list->string chars)))
113 189
114 < ; result will contain || if separator at end of symbol; could use
115 < ; that to mean something
116 <
117 < (define (tokens separator source token acc)
190 > (define (tokens test source token acc keepsep?)
118 191 (cond ((null? source)
119 < (reverse (cons (reverse token) acc)))
120 < ((eqv? (car source) separator)
121 < (tokens separator
192 > (reverse (if (pair? token)
193 > (cons (reverse token) acc)
194 > acc)))
195 > ((test (car source))
196 > (tokens test
122 197 (cdr source)
123 198 '()
124 < (cons (reverse token) acc)))
199 > (let ((rec (if (null? token)
200 > acc
201 > (cons (reverse token) acc))))
202 > (if keepsep?
203 > (cons (car source) rec)
204 > rec))
205 > keepsep?))
125 206 (#t
126 < (tokens separator
207 > (tokens test
127 208 (cdr source)
128 209 (cons (car source) token)
129 < acc))))
130 <
131 < ; Purely an optimization. Could in principle do it with a preprocessor
132 < ; instead of adding a line to ac, but only want to do it for evaluated
133 < ; subtrees, and much easier to figure those out in ac.
134 <
135 < (define (decompose fns args)
136 < (cond ((null? fns) `((fn vals (car vals)) ,@args))
137 < ((null? (cdr fns)) (cons (car fns) args))
138 < (#t (list (car fns) (decompose (cdr fns) args)))))
139 <
210 > acc
211 > keepsep?))))
140 212
141 213 (define (ac-global-name s)
142 214 (string->symbol (string-append "_" (symbol->string s))))
143 215
144 216 (define (ac-var-ref s env)
145 217 (if (lex? s env)
146 218 s
147 219 (ac-global-name s)))
148 220
149 221 ; quasiquote
150 222
151 223 (define (ac-qq args env)
152 224 (list 'quasiquote (ac-qq1 1 args env)))
153 225
154 226 ; process the argument of a quasiquote. keep track of
155 227 ; depth of nesting. handle unquote only at top level (level = 1).
156 228 ; complete form, e.g. x or (fn x) or (unquote (fn x))
229 >
157 230 (define (ac-qq1 level x env)
158 231 (cond ((= level 0)
159 232 (ac x env))
160 233 ((and (pair? x) (eqv? (car x) 'unquote))
161 234 (list 'unquote (ac-qq1 (- level 1) (cadr x) env)))
162 235 ((and (pair? x) (eqv? (car x) 'unquote-splicing) (= level 1))
163 236 (list 'unquote-splicing
164 237 (list 'ar-nil-terminate (ac-qq1 (- level 1) (cadr x) env))))
165 238 ((and (pair? x) (eqv? (car x) 'quasiquote))
166 239 (list 'quasiquote (ac-qq1 (+ level 1) (cadr x) env)))
167 240 ((pair? x)
168 < (map (lambda (x) (ac-qq1 level x env)) x))
241 > (imap (lambda (x) (ac-qq1 level x env)) x))
169 242 (#t x)))
243 >
244 > ; like map, but don't demand '()-terminated list
245 >
246 > (define (imap f l)
247 > (cond ((pair? l)
248 > (cons (f (car l)) (imap f (cdr l))))
249 > ((null? l)
250 > '())
251 > (#t (f l))))
170 252
171 253 ; (if) -> nil
172 254 ; (if x) -> x
173 255 ; (if t a ...) -> a
174 256 ; (if nil a b) -> b
175 257 ; (if nil a b c) -> (if b c)
176 258
177 259 (define (ac-if args env)
178 260 (cond ((null? args) ''nil)
179 261 ((null? (cdr args)) (ac (car args) env))
180 262 (#t `(if (not (ar-false? ,(ac (car args) env)))
181 < ;(not (eq? 'nil ,(ac (car args) env)))
182 263 ,(ac (cadr args) env)
183 264 ,(ac-if (cddr args) env)))))
184 265
266 > (define (ac-dbname! name env)
267 > (if (symbol? name)
268 > (cons (list name) env)
269 > env))
270 >
271 > (define (ac-dbname env)
272 > (cond ((null? env) #f)
273 > ((pair? (car env)) (caar env))
274 > (#t (ac-dbname (cdr env)))))
275 >
185 276 ; translate fn directly into a lambda if it has ordinary
186 277 ; parameters, otherwise use a rest parameter and parse it.
278 >
187 279 (define (ac-fn args body env)
188 280 (if (ac-complex-args? args)
189 281 (ac-complex-fn args body env)
190 < `(lambda ,(let ((a (ac-denil args))) (if (eqv? a 'nil) '() a))
191 < 'nil
192 < ,@(ac-body body (append (ac-arglist args) env)))))
282 > (ac-nameit
283 > (ac-dbname env)
284 > `(lambda ,(let ((a (ac-denil args))) (if (eqv? a 'nil) '() a))
285 > ,@(ac-body* body (append (ac-arglist args) env))))))
193 286
194 287 ; does an fn arg list use optional parameters or destructuring?
195 288 ; a rest parameter is not complex
289 >
196 290 (define (ac-complex-args? args)
197 291 (cond ((eqv? args '()) #f)
198 292 ((symbol? args) #f)
199 293 ((and (pair? args) (symbol? (car args)))
200 294 (ac-complex-args? (cdr args)))
201 295 (#t #t)))
202 296
203 297 ; translate a fn with optional or destructuring args
204 298 ; (fn (x (o y x) (o z 21) (x1 x2) . rest) ...)
205 299 ; arguments in top-level list are mandatory (unless optional),
206 300 ; but it's OK for parts of a list you're destructuring to
207 301 ; be missing.
302 >
208 303 (define (ac-complex-fn args body env)
209 304 (let* ((ra (ar-gensym))
210 305 (z (ac-complex-args args env ra #t)))
211 306 `(lambda ,ra
212 307 (let* ,z
213 < 'nil
214 < ,@(ac-body body (append (ac-complex-getargs z) env))))))
308 > ,@(ac-body* body (append (ac-complex-getargs z) env))))))
215 309
216 310 ; returns a list of two-element lists, first is variable name,
217 311 ; second is (compiled) expression. to be used in a let.
218 312 ; caller should extract variables and add to env.
219 313 ; ra is the rest argument to the fn.
220 314 ; is-params indicates that args are function arguments
221 315 ; (not destructuring), so they must be passed or be optional.
316 >
222 317 (define (ac-complex-args args env ra is-params)
223 318 (cond ((or (eqv? args '()) (eqv? args 'nil)) '())
224 319 ((symbol? args) (list (list args ra)))
225 320 ((pair? args)
226 321 (let* ((x (if (and (pair? (car args)) (eqv? (caar args) 'o))
227 322 (ac-complex-opt (cadar args)
228 323 (if (pair? (cddar args))
229 324 (caddar args)
230 325 'nil)
231 326 env
232 327 ra)
233 328 (ac-complex-args
234 329 (car args)
235 330 env
236 331 (if is-params
237 332 `(car ,ra)
238 333 `(ar-xcar ,ra))
239 334 #f)))
240 335 (xa (ac-complex-getargs x)))
241 336 (append x (ac-complex-args (cdr args)
242 337 (append xa env)
243 338 `(ar-xcdr ,ra)
244 339 is-params))))
245 340 (#t (err "Can't understand fn arg list" args))))
246 341
247 342 ; (car ra) is the argument
248 343 ; so it's not present if ra is nil or '()
344 >
249 345 (define (ac-complex-opt var expr env ra)
250 346 (list (list var `(if (pair? ,ra) (car ,ra) ,(ac expr env)))))
251 347
252 348 ; extract list of variables from list of two-element lists.
349 >
253 350 (define (ac-complex-getargs a)
254 351 (map (lambda (x) (car x)) a))
255 352
256 353 ; (a b . c) -> (a b c)
257 354 ; a -> (a)
355 >
258 356 (define (ac-arglist a)
259 357 (cond ((null? a) '())
260 358 ((symbol? a) (list a))
261 359 ((symbol? (cdr a)) (list (car a) (cdr a)))
262 360 (#t (cons (car a) (ac-arglist (cdr a))))))
263 361
264 362 (define (ac-body body env)
363 > (map (lambda (x) (ac x env)) body))
364 >
365 > ; like ac-body, but spits out a nil expression if empty
366 >
367 > (define (ac-body* body env)
265 368 (if (null? body)
266 < '()
267 < (cons (ac (car body) env) (ac-body (cdr body) env))))
369 > (list (list 'quote 'nil))
370 > (ac-body body env)))
268 371
269 372 ; (set v1 expr1 v2 expr2 ...)
270 373
271 374 (define (ac-set x env)
272 375 `(begin ,@(ac-setn x env)))
273 376
274 377 (define (ac-setn x env)
275 378 (if (null? x)
276 379 '()
277 < (cons (ac-set1 (ac-macex (car x)) (ac (cadr x) env) env)
380 > (cons (ac-set1 (ac-macex (car x)) (cadr x) env)
278 381 (ac-setn (cddr x) env))))
279 382
383 > ; trick to tell Scheme the name of something, so Scheme
384 > ; debugging and profiling make more sense.
385 >
386 > (define (ac-nameit name v)
387 > (if (symbol? name)
388 > (let ((n (string->symbol (string-append " " (symbol->string name)))))
389 > (list 'let `((,n ,v)) n))
390 > v))
391 >
280 392 ; = replaced by set, which is only for vars
281 393 ; = now defined in arc (is it?)
282 394 ; name is to cause fns to have their arc names for debugging
283 395
284 < (define (ac-set1 a b env)
396 > (define (ac-set1 a b1 env)
285 397 (if (symbol? a)
286 < (let ((name (string->symbol (string-append " " (symbol->string a)))))
287 < (list 'let `((,name ,b))
398 > (let ((b (ac b1 (ac-dbname! a env))))
399 > (list 'let `((zz ,b))
288 400 (cond ((eqv? a 'nil) (err "Can't rebind nil"))
289 401 ((eqv? a 't) (err "Can't rebind t"))
290 < ((lex? a env) `(set! ,a ,name))
402 > ((lex? a env) `(set! ,a zz))
291 403 (#t `(namespace-set-variable-value! ',(ac-global-name a)
292 < ,name)))
293 < name))
404 > zz)))
405 > 'zz))
294 406 (err "First arg to set must be a symbol" a)))
407 >
408 > ; given a list of Arc expressions, return a list of Scheme expressions.
409 > ; for compiling passed arguments.
410 >
411 > (define (ac-args names exprs env)
412 > (if (null? exprs)
413 > '()
414 > (cons (ac (car exprs)
415 > (ac-dbname! (if (pair? names) (car names) #f) env))
416 > (ac-args (if (pair? names) (cdr names) '())
417 > (cdr exprs)
418 > env))))
419 >
420 > ; generate special fast code for ordinary two-operand
421 > ; calls to the following functions. this is to avoid
422 > ; calling e.g. ar-is with its &rest and apply.
423 >
424 > (define ac-binaries
425 > '((is ar-is2)
426 > (< ar-<2)
427 > (> ar->2)
428 > (+ ar-+2)))
429 >
430 > ; (foo bar) where foo is a global variable bound to a procedure.
431 >
432 > (define (ac-global-call fn args env)
433 > (cond ((and (assoc fn ac-binaries) (= (length args) 2))
434 > `(,(cadr (assoc fn ac-binaries)) ,@(ac-args '() args env)))
435 > (#t
436 > `(,(ac-global-name fn) ,@(ac-args '() args env)))))
295 437
296 438 ; compile a function call
297 439 ; special cases for speed, to avoid compiled output like
298 440 ; (ar-apply _pr (list 1 2))
299 441 ; which results in 1/2 the CPU time going to GC. Instead:
300 442 ; (ar-funcall2 _pr 1 2)
443 > ; and for (foo bar), if foo is a reference to a global variable,
444 > ; and it's bound to a function, generate (foo bar) instead of
445 > ; (ar-funcall1 foo bar)
446 >
447 > (define direct-calls #f)
448 >
301 449 (define (ac-call fn args env)
302 450 (let ((macfn (ac-macro? fn)))
303 451 (cond (macfn
304 452 (ac-mac-call macfn args env))
305 453 ((and (pair? fn) (eqv? (car fn) 'fn))
306 < `(,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
454 > `(,(ac fn env) ,@(ac-args (cadr fn) args env)))
455 > ((and direct-calls (symbol? fn) (not (lex? fn env)) (bound? fn)
456 > (procedure? (namespace-variable-value (ac-global-name fn))))
457 > (ac-global-call fn args env))
307 458 ((= (length args) 0)
308 459 `(ar-funcall0 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
309 460 ((= (length args) 1)
310 461 `(ar-funcall1 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
311 462 ((= (length args) 2)
312 463 `(ar-funcall2 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
313 464 ((= (length args) 3)
314 465 `(ar-funcall3 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
315 466 ((= (length args) 4)
316 467 `(ar-funcall4 ,(ac fn env) ,@(map (lambda (x) (ac x env)) args)))
317 468 (#t
318 469 `(ar-apply ,(ac fn env)
319 470 (list ,@(map (lambda (x) (ac x env)) args)))))))
320 471
321 472 (define (ac-mac-call m args env)
322 473 (let ((x1 (apply m (map ac-niltree args))))
323 474 (let ((x2 (ac (ac-denil x1) env)))
324 475 x2)))
325 476
326 477 ; returns #f or the macro function
327 478
328 479 (define (ac-macro? fn)
329 480 (if (symbol? fn)
330 481 (let ((v (namespace-variable-value (ac-global-name fn)
331 482 #t
332 483 (lambda () #f))))
333 484 (if (and v
334 485 (ar-tagged? v)
335 486 (eq? (ar-type v) 'mac))
336 487 (ar-rep v)
337 488 #f))
338 489 #f))
339 490
340 491 ; macroexpand the outer call of a form as much as possible
341 492
342 493 (define (ac-macex e . once)
343 494 (if (pair? e)
344 495 (let ((m (ac-macro? (car e))))
345 496 (if m
346 497 (let ((expansion (ac-denil (apply m (map ac-niltree (cdr e))))))
347 498 (if (null? once) (ac-macex expansion) expansion))
348 499 e))
349 500 e))
350 501
351 502 ; macros return Arc lists, ending with NIL.
352 503 ; but the Arc compiler expects Scheme lists, ending with '().
353 504 ; what to do with (is x nil . nil) ?
354 505 ; the first nil ought to be replaced with 'NIL
355 506 ; the second with '()
356 507 ; so the rule is: NIL in the car -> 'NIL, NIL in the cdr -> '().
357 508 ; NIL by itself -> NIL
358 509
359 510 (define (ac-denil x)
360 511 (cond ((pair? x) (cons (ac-denil-car (car x)) (ac-denil-cdr (cdr x))))
361 512 (#t x)))
362 513
363 514 (define (ac-denil-car x)
364 515 (if (eq? x 'nil)
365 516 'nil
366 517 (ac-denil x)))
367 518
368 519 (define (ac-denil-cdr x)
369 520 (if (eq? x 'nil)
370 521 '()
371 522 (ac-denil x)))
372 523
373 524 ; is v lexically bound?
525 >
374 526 (define (lex? v env)
375 527 (memq v env))
376 528
377 529 (define (xcar x)
378 530 (and (pair? x) (car x)))
379 531
380 532 ; #f and '() -> nil for a whole quoted list/tree.
381 533
534 > ; Arc primitives written in Scheme should look like:
535 >
536 > ; (xdef foo (lambda (lst)
537 > ; (ac-niltree (scheme-foo (ar-nil-terminate lst)))))
538 >
539 > ; That is, Arc lists are NIL-terminated. When calling a Scheme
540 > ; function that treats an argument as a list, call ar-nil-terminate
541 > ; to change NIL to '(). When returning any data created by Scheme
542 > ; to Arc, call ac-niltree to turn all '() into NIL.
543 > ; (hash-table-get doesn't use its argument as a list, so it doesn't
544 > ; need ar-nil-terminate).
545 >
382 546 (define (ac-niltree x)
383 547 (cond ((pair? x) (cons (ac-niltree (car x)) (ac-niltree (cdr x))))
384 548 ((or (eq? x #f) (eq? x '())) 'nil)
385 549 (#t x)))
386 550
387 < ;(define (err msg . args)
388 < ; (display msg)
389 < ; (map (lambda (a) (display " ") (write a)) args)
390 < ; (newline)
391 < ; (xxundefined))
392 <
393 < (define err error) ; eli says need to remove xxundefined for speed
551 > ; The next two are optimizations, except work for macros.
552 >
553 > (define (decompose fns args)
554 > (cond ((null? fns) `((fn vals (car vals)) ,@args))
555 > ((null? (cdr fns)) (cons (car fns) args))
556 > (#t (list (car fns) (decompose (cdr fns) args)))))
557 >
558 > (define (ac-andf s env)
559 > (ac (let ((gs (map (lambda (x) (ar-gensym)) (cdr s))))
560 > `((fn ,gs
561 > (and ,@(map (lambda (f) `(,f ,@gs))
562 > (cdar s))))
563 > ,@(cdr s)))
564 > env))
565 >
566 > (define err error)
394 567
395 568 ; run-time primitive procedures
396 569
397 < (define (xdef a b)
398 < (namespace-set-variable-value! (ac-global-name a) b)
399 < b)
570 > ;(define (xdef a b)
571 > ; (namespace-set-variable-value! (ac-global-name a) b)
572 > ; b)
400 573
574 > (define-syntax xdef
575 > (syntax-rules ()
576 > ((xxdef a b)
577 > (let ((nm (ac-global-name 'a))
578 > (a b))
579 > (namespace-set-variable-value! nm a)
580 > a))))
581 >
401 582 (define fn-signatures (make-hash-table 'equal))
402 583
403 584 ; This is a replacement for xdef that stores opeator signatures.
404 585 ; Haven't started using it yet.
405 586
406 587 (define (odef a parms b)
407 588 (namespace-set-variable-value! (ac-global-name a) b)
408 589 (hash-table-put! fn-signatures a (list parms))
409 590 b)
410 591
411 < (xdef 'sig fn-signatures)
592 > (xdef sig fn-signatures)
412 593
413 594 ; versions of car and cdr for parsing arguments for optional
414 595 ; parameters, that yield nil for nil. maybe we should use
415 596 ; full Arc car and cdr, so we can destructure more things
416 597
417 598 (define (ar-xcar x)
418 599 (if (or (eqv? x 'nil) (eqv? x '()))
419 600 'nil
420 601 (car x)))
421 602
422 603 (define (ar-xcdr x)
423 604 (if (or (eqv? x 'nil) (eqv? x '()))
424 605 'nil
425 606 (cdr x)))
426 607
427 608 ; convert #f from a Scheme predicate to NIL.
428 609
429 610 (define (ar-nill x)
430 611 (if (or (eq? x '()) (eq? x #f))
431 612 'nil
432 613 x))
433 614
434 615 ; definition of falseness for Arc if.
435 616 ; must include '() since sometimes Arc functions see
436 617 ; Scheme lists (e.g. . body of a macro).
437 618
438 619 (define (ar-false? x)
439 620 (or (eq? x 'nil) (eq? x '()) (eq? x #f)))
440 621
441 < #|
442 < (if (eq? x 'nil) #t
443 < (if (eq? x '()) #t
444 < (not x)))
445 < |#
446 <
447 622 ; call a function or perform an array ref, hash ref, &c
448 623
449 < ; Non-fn donstants in functional position are valuable real estate, so
450 < ; should figure out the best way to exploit it.
624 > ; Non-fn constants in functional position are valuable real estate, so
625 > ; should figure out the best way to exploit it. What could (1 foo) or
626 > ; ('a foo) mean? Maybe it should mean currying.
451 627
628 > ; For now the way to make the default val of a hash table be other than
629 > ; nil is to supply the val when doing the lookup. Later may also let
630 > ; defaults be supplied as an arg to table. To implement this, need: an
631 > ; eq table within scheme mapping tables to defaults, and to adapt the
632 > ; code in arc.arc that reads and writes tables to read and write their
633 > ; default vals with them. To make compatible with existing written tables,
634 > ; just use an atom or 3-elt list to keep the default.
635 >
452 636 (define (ar-apply fn args)
453 < (cond ((procedure? fn) (apply fn args))
454 < ((pair? fn) (list-ref fn (car args)))
455 < ((string? fn) (string-ref fn (car args)))
456 < ((hash-table? fn) (ar-nill (hash-table-get fn (car args) #f)))
637 > (cond ((procedure? fn)
638 > (apply fn args))
639 > ((pair? fn)
640 > (list-ref fn (car args)))
641 > ((string? fn)
642 > (string-ref fn (car args)))
643 > ((hash-table? fn)
644 > (ar-nill (hash-table-get fn
645 > (car args)
646 > (if (pair? (cdr args)) (cadr args) #f))))
457 647 ; experiment: means e.g. [1] is a constant fn
458 648 ; ((or (number? fn) (symbol? fn)) fn)
459 649 ; another possibility: constant in functional pos means it gets
460 650 ; passed to the first arg, i.e. ('kids item) means (item 'kids).
461 651 (#t (err "Function call on inappropriate object" fn args))))
462 652
463 < (xdef 'apply (lambda (fn . args)
653 > (xdef apply (lambda (fn . args)
464 654 (ar-apply fn (ar-apply-args args))))
465 655
466 656 ; special cases of ar-apply for speed and to avoid consing arg lists
657 >
467 658 (define (ar-funcall0 fn)
468 659 (if (procedure? fn)
469 660 (fn)
470 661 (ar-apply fn (list))))
471 662
472 663 (define (ar-funcall1 fn arg1)
473 664 (if (procedure? fn)
474 665 (fn arg1)
475 666 (ar-apply fn (list arg1))))
476 667
477 668 (define (ar-funcall2 fn arg1 arg2)
478 669 (if (procedure? fn)
479 670 (fn arg1 arg2)
480 671 (ar-apply fn (list arg1 arg2))))
481 672
482 673 (define (ar-funcall3 fn arg1 arg2 arg3)
483 674 (if (procedure? fn)
484 675 (fn arg1 arg2 arg3)
485 676 (ar-apply fn (list arg1 arg2 arg3))))
486 677
487 678 (define (ar-funcall4 fn arg1 arg2 arg3 arg4)
488 679 (if (procedure? fn)
489 680 (fn arg1 arg2 arg3 arg4)
490 681 (ar-apply fn (list arg1 arg2 arg3 arg4))))
491 682
492 683 ; replace the nil at the end of a list with a '()
493 684
494 685 (define (ar-nil-terminate l)
495 686 (if (or (eqv? l '()) (eqv? l 'nil))
496 687 '()
497 688 (cons (car l) (ar-nil-terminate (cdr l)))))
498 689
499 690 ; turn the arguments to Arc apply into a list.
500 691 ; if you call (apply fn 1 2 '(3 4))
501 692 ; then args is '(1 2 (3 4 . nil) . ())
502 693 ; that is, the main list is a scheme list.
503 694 ; and we should return '(1 2 3 4 . ())
504 695 ; was once (apply apply list (ac-denil args))
505 696 ; but that didn't work for (apply fn nil)
506 697
507 698 (define (ar-apply-args args)
508 699 (cond ((null? args) '())
509 700 ((null? (cdr args)) (ar-nil-terminate (car args)))
510 701 (#t (cons (car args) (ar-apply-args (cdr args))))))
511 702
512 < (xdef 'cons cons)
703 >
704 >
705 >
706 >
707 > (xdef cons cons)
513 708
514 < (xdef 'car (lambda (x)
709 > (xdef car (lambda (x)
515 710 (cond ((pair? x) (car x))
516 711 ((eqv? x 'nil) 'nil)
517 712 ((eqv? x '()) 'nil)
518 713 (#t (err "Can't take car of" x)))))
519 714
520 < (xdef 'cdr (lambda (x)
715 > (xdef cdr (lambda (x)
521 716 (cond ((pair? x) (cdr x))
522 717 ((eqv? x 'nil) 'nil)
523 718 ((eqv? x '()) 'nil)
524 719 (#t (err "Can't take cdr of" x)))))
525 720
721 > (define (tnil x) (if x 't 'nil))
722 >
723 > ; (pairwise pred '(a b c d)) =>
724 > ; (and (pred a b) (pred b c) (pred c d))
725 > ; pred returns t/nil, as does pairwise
526 726 ; reduce?
527 727
528 < (define (pairwise pred args base)
529 < (let ((n (length args)))
530 < (cond ((< n 2) base)
531 < ((= n 2) (apply pred args))
532 < (#t (and (pred (car args) (cadr args))
533 < (pairwise pred (cdr args) base))))))
728 > (define (pairwise pred lst)
729 > (cond ((null? lst) 't)
730 > ((null? (cdr lst)) 't)
731 > ((not (eqv? (pred (car lst) (cadr lst)) 'nil))
732 > (pairwise pred (cdr lst)))
733 > (#t 'nil)))
534 734
535 735 ; not quite right, because behavior of underlying eqv unspecified
536 736 ; in many cases according to r5rs
537 737 ; do we really want is to ret t for distinct strings?
538 738
539 < (xdef 'is (lambda args
540 < (if (or (all (lambda (a) (eqv? (car args) a)) (cdr args))
541 < (and (all string? args)
542 < (apply string=? args))
543 < (all ar-false? args))
544 < 't 'nil)))
739 > ; for (is x y)
740 >
741 > (define (ar-is2 a b)
742 > (tnil (or (eqv? a b)
743 > (and (string? a) (string? b) (string=? a b))
744 > (and (ar-false? a) (ar-false? b)))))
745 >
746 > ; for all other uses of is
545 747
546 < (xdef 'err err)
547 < (xdef 'nil 'nil)
548 < (xdef 't 't)
748 > (xdef is (lambda args (pairwise ar-is2 args)))
749 >
750 > (xdef err err)
751 > (xdef nil 'nil)
752 > (xdef t 't)
549 753
550 754 (define (all test seq)
551 755 (or (null? seq)
552 756 (and (test (car seq)) (all test (cdr seq)))))
553 757
554 < ; rather strictly excludes ()
555 <
556 < (define (arc-list? x) (or (pair? x) (eqv? x 'nil)))
758 > (define (arc-list? x) (or (pair? x) (eqv? x 'nil) (eqv? x '())))
557 759
558 < ; generic +: strings, lists, numbers.
559 < ; problem with generic +: what to return when no args?
560 < ; could even coerce based on type of first arg...
760 > ; Generic +: strings, lists, numbers.
761 > ; Return val has same type as first argument.
561 762
562 < (xdef '+ (lambda args
763 > (xdef + (lambda args
563 764 (cond ((null? args) 0)
564 < ((all string? args)
565 < (apply string-append args))
566 < ((all arc-list? args)
765 > ((char-or-string? (car args))
766 > (apply string-append
767 > (map (lambda (a) (ar-coerce a 'string))
768 > args)))
769 > ((arc-list? (car args))
567 770 (ac-niltree (apply append (map ar-nil-terminate args))))
568 771 (#t (apply + args)))))
569 772
570 < (xdef '- -)
571 < (xdef '* *)
572 < (xdef '/ /)
573 < (xdef 'mod modulo)
574 < (xdef 'expt expt)
575 < (xdef 'sqrt sqrt)
773 > (define (char-or-string? x) (or (string? x) (char? x)))
774 >
775 > (define (ar-+2 x y)
776 > (cond ((char-or-string? x)
777 > (string-append (ar-coerce x 'string) (ar-coerce y 'string)))
778 > ((and (arc-list? x) (arc-list? y))
779 > (ac-niltree (append (ar-nil-terminate x) (ar-nil-terminate y))))
780 > (#t (+ x y))))
781 >
782 > (xdef - -)
783 > (xdef * *)
784 > (xdef / /)
785 > (xdef mod modulo)
786 > (xdef expt expt)
787 > (xdef sqrt sqrt)
576 788
577 789 ; generic comparison
578 790
579 < (define (arc> . args)
580 < (cond ((all number? args) (apply > args))
581 < ((all string? args) (pairwise string>? args #f))
582 < ((all symbol? args) (pairwise (lambda (x y)
583 < (string>? (symbol->string x)
584 < (symbol->string y)))
585 < args
586 < #f))
587 < ((all char? args) (pairwise char>? args #f))
588 < (#t (apply > args))))
589 < (xdef '> (lambda args (if (apply arc> args) 't 'nil)))
791 > (define (ar->2 x y)
792 > (tnil (cond ((and (number? x) (number? y)) (> x y))
793 > ((and (string? x) (string? y)) (string>? x y))
794 > ((and (symbol? x) (symbol? y)) (string>? (symbol->string x)
795 > (symbol->string y)))
796 > ((and (char? x) (char? y)) (char>? x y))
797 > (#t (> x y)))))
798 >
799 > (xdef > (lambda args (pairwise ar->2 args)))
590 800
591 < (define (arc< . args)
592 < (cond ((all number? args) (apply < args))
593 < ((all string? args) (pairwise stringstring x)
596 < (symbol->string y)))
597 < args
598 < #f))
599 < ((all char? args) (pairwise char (define (ar-<2 x y)
802 > (tnil (cond ((and (number? x) (number? y)) (< x y))
803 > ((and (string? x) (string? y)) (string ((and (symbol? x) (symbol? y)) (stringstring x)
805 > (symbol->string y)))
806 > ((and (char? x) (char? y)) (char (#t (< x y)))))
808 >
809 > (xdef < (lambda args (pairwise ar-<2 args)))
602 810
603 < (xdef 'len (lambda (x)
811 > (xdef len (lambda (x)
604 812 (cond ((string? x) (string-length x))
605 813 ((hash-table? x) (hash-table-count x))
606 814 (#t (length (ar-nil-terminate x))))))
607 815
608 816 (define (ar-tagged? x)
609 817 (and (vector? x) (eq? (vector-ref x 0) 'tagged)))
610 818
611 819 (define (ar-tag type rep)
612 820 (cond ((eqv? (ar-type rep) type) rep)
613 821 (#t (vector 'tagged type rep))))
614 < (xdef 'annotate ar-tag)
822 >
823 > (xdef annotate ar-tag)
615 824
616 825 ; (type nil) -> sym
826 >
827 > (define (exint? x) (and (integer? x) (exact? x)))
617 828
618 829 (define (ar-type x)
619 830 (cond ((ar-tagged? x) (vector-ref x 1))
620 831 ((pair? x) 'cons)
621 832 ((symbol? x) 'sym)
622 833 ((null? x) 'sym)
623 834 ((procedure? x) 'fn)
624 835 ((char? x) 'char)
625 836 ((string? x) 'string)
626 < ((integer? x) 'int)
837 > ((exint? x) 'int)
627 838 ((number? x) 'num) ; unsure about this
628 839 ((hash-table? x) 'table)
629 840 ((output-port? x) 'output)
630 841 ((input-port? x) 'input)
631 842 ((tcp-listener? x) 'socket)
632 843 ((exn? x) 'exception)
844 > ((thread? x) 'thread)
633 845 (#t (err "Type: unknown type" x))))
634 < (xdef 'type ar-type)
846 > (xdef type ar-type)
635 847
636 848 (define (ar-rep x)
637 849 (if (ar-tagged? x)
638 850 (vector-ref x 2)
639 851 x))
640 < (xdef 'rep ar-rep)
852 >
853 > (xdef rep ar-rep)
641 854
642 855 ; currently rather a joke: returns interned symbols
643 856
644 857 (define ar-gensym-count 0)
858 >
645 859 (define (ar-gensym)
646 860 (set! ar-gensym-count (+ ar-gensym-count 1))
647 861 (string->symbol (string-append "gs" (number->string ar-gensym-count))))
648 < (xdef 'uniq ar-gensym)
862 >
863 > (xdef uniq ar-gensym)
649 864
650 < (xdef 'ccc call-with-current-continuation)
865 > (xdef ccc call-with-current-continuation)
651 866
652 < (xdef 'infile open-input-file)
653 < (xdef 'outfile (lambda (f . args)
867 > (xdef infile open-input-file)
868 >
869 > (xdef outfile (lambda (f . args)
654 870 (open-output-file f
655 871 'text
656 872 (if (equal? args '(append))
657 873 'append
658 874 'truncate))))
659 875
660 < (xdef 'instring open-input-string)
661 < (xdef 'outstring open-output-string)
876 > (xdef instring open-input-string)
877 > (xdef outstring open-output-string)
662 878
663 879 ; use as general fn for looking inside things
664 880
665 < (xdef 'inside get-output-string)
881 > (xdef inside get-output-string)
666 882
667 < (xdef 'close (lambda (p)
668 < (cond ((input-port? p) (close-input-port p))
669 < ((output-port? p) (close-output-port p))
670 < ((tcp-listener? p) (tcp-close p))
671 < (#t (err "Can't close " p)))
672 < 'nil))
673 <
674 < (xdef 'stdout current-output-port) ; should be a vars
675 < (xdef 'stdin current-input-port)
676 < (xdef 'stderr current-error-port)
883 > (xdef stdout current-output-port) ; should be a vars
884 > (xdef stdin current-input-port)
885 > (xdef stderr current-error-port)
677 886
678 < (xdef 'call-w/stdout
887 > (xdef call-w/stdout
679 888 (lambda (port thunk)
680 889 (parameterize ((current-output-port port)) (thunk))))
681 890
682 < (xdef 'call-w/stdin
891 > (xdef call-w/stdin
683 892 (lambda (port thunk)
684 893 (parameterize ((current-input-port port)) (thunk))))
685 894
686 < ; (readc stream)
687 < ; nil stream means stdout
688 < ; returns nil on eof
689 <
690 < (xdef 'readc (lambda (str)
691 < (let ((p (if (ar-false? str)
692 < (current-input-port)
693 < str)))
694 < (let ((c (read-char p)))
695 < (if (eof-object? c) 'nil c)))))
895 > (xdef readc (lambda str
896 > (let ((c (read-char (if (pair? str)
897 > (car str)
898 > (current-input-port)))))
899 > (if (eof-object? c) 'nil c))))
696 900
697 < (xdef 'readb (lambda (str)
698 < (let ((p (if (ar-false? str)
699 < (current-input-port)
700 < str)))
701 < (let ((c (read-byte p)))
702 < (if (eof-object? c) 'nil c)))))
901 >
902 > (xdef readb (lambda str
903 > (let ((c (read-byte (if (pair? str)
904 > (car str)
905 > (current-input-port)))))
906 > (if (eof-object? c) 'nil c))))
703 907
704 < (xdef 'peekc (lambda (str)
705 < (let ((p (if (ar-false? str)
706 < (current-input-port)
707 < str)))
708 < (let ((c (peek-char p)))
709 < (if (eof-object? c) 'nil c)))))
908 > (xdef peekc (lambda str
909 > (let ((c (peek-char (if (pair? str)
910 > (car str)
911 > (current-input-port)))))
912 > (if (eof-object? c) 'nil c))))
710 913
711 < (xdef 'writec (lambda (c . args)
914 > (xdef writec (lambda (c . args)
712 915 (write-char c
713 916 (if (pair? args)
714 917 (car args)
715 918 (current-output-port)))
716 919 c))
717 920
718 < (xdef 'writeb (lambda (b . args)
921 > (xdef writeb (lambda (b . args)
719 922 (write-byte b
720 923 (if (pair? args)
721 924 (car args)
722 925 (current-output-port)))
723 926 b))
724 927
725 < (xdef 'write (lambda args
726 < (if (pair? args)
727 < (write (ac-denil (car args))
728 < (if (pair? (cdr args))
729 < (cadr args)
730 < (current-output-port))))
731 < (flush-output)
732 < 'nil))
733 <
734 < (xdef 'disp (lambda args
735 < (if (pair? args)
736 < (display (ac-denil (car args))
737 < (if (pair? (cdr args))
738 < (cadr args)
739 < (current-output-port))))
740 < (flush-output)
741 < 'nil))
928 > (define explicit-flush #f)
929 >
930 > (define (printwith f args)
931 > (let ((port (if (> (length args) 1)
932 > (cadr args)
933 > (current-output-port))))
934 > (when (pair? args)
935 > (f (ac-denil (car args)) port))
936 > (unless explicit-flush (flush-output port)))
937 > 'nil)
742 938
939 > (xdef write (lambda args (printwith write args)))
940 > (xdef disp (lambda args (printwith display args)))
941 >
743 942 ; sread = scheme read. eventually replace by writing read
744 943
745 < (xdef 'sread (lambda (p eof)
944 > (xdef sread (lambda (p eof)
746 945 (let ((expr (read p)))
747 946 (if (eof-object? expr) eof expr))))
748 947
749 948 ; these work in PLT but not scheme48
750 949
751 950 (define char->ascii char->integer)
752 951 (define ascii->char integer->char)
753 952
754 < (xdef 'coerce (lambda (x type . args)
755 < (cond
756 < ((ar-tagged? x) (err "Can't coerce annotated object"))
757 < ((eqv? type (ar-type x)) x)
758 <
759 < ((char? x) (case type
760 < ((int) (char->ascii x))
761 < ((string) (string x))
762 < ((sym) (string->symbol (string x)))
763 < (else (err "Can't coerce" x type))))
764 < ((integer? x) (case type
765 < ((char) (ascii->char x))
766 < ((string) (apply number->string x args))
767 < (else (err "Can't coerce" x type))))
768 < ((number? x) (case type
769 < ((int) (round x))
770 < ((char) (ascii->char (round x)))
771 < ((string) (apply number->string x args))
772 < (else (err "Can't coerce" x type))))
773 < ((string? x) (case type
774 < ((sym) (string->symbol x))
775 < ((cons) (ac-niltree (string->list x)))
776 < ((int) (or (apply string->number x args)
777 < (err "Can't coerce" x type)))
778 < (else (err "Can't coerce" x type))))
779 < ((pair? x) (case type
780 < ((string) (list->string
781 < (ar-nil-terminate x)))
782 < (else (err "Can't coerce" x type))))
783 < ((eqv? x 'nil) (case type
784 < ((string) "")
785 < (else (err "Can't coerce" x type))))
786 < ((symbol? x) (case type
787 < ((string) (symbol->string x))
788 < (else (err "Can't coerce" x type))))
789 < (#t x))))
953 > (define (iround x) (inexact->exact (round x)))
954 >
955 > (define (ar-coerce x type . args)
956 > (cond
957 > ((ar-tagged? x) (err "Can't coerce annotated object"))
958 > ((eqv? type (ar-type x)) x)
959 > ((char? x) (case type
960 > ((int) (char->ascii x))
961 > ((string) (string x))
962 > ((sym) (string->symbol (string x)))
963 > (else (err "Can't coerce" x type))))
964 > ((exint? x) (case type
965 > ((num) x)
966 > ((char) (ascii->char x))
967 > ((string) (apply number->string x args))
968 > (else (err "Can't coerce" x type))))
969 > ((number? x) (case type
970 > ((int) (iround x))
971 > ((char) (ascii->char (iround x)))
972 > ((string) (apply number->string x args))
973 > (else (err "Can't coerce" x type))))
974 > ((string? x) (case type
975 > ((sym) (string->symbol x))
976 > ((cons) (ac-niltree (string->list x)))
977 > ((num) (or (apply string->number x args)
978 > (err "Can't coerce" x type)))
979 > ((int) (let ((n (apply string->number x args)))
980 > (if n
981 > (iround n)
982 > (err "Can't coerce" x type))))
983 > (else (err "Can't coerce" x type))))
984 > ((pair? x) (case type
985 > ((string) (apply string-append
986 > (map (lambda (y) (ar-coerce y 'string))
987 > (ar-nil-terminate x))))
988 > (else (err "Can't coerce" x type))))
989 > ((eqv? x 'nil) (case type
990 > ((string) "")
991 > (else (err "Can't coerce" x type))))
992 > ((null? x) (case type
993 > ((string) "")
994 > (else (err "Can't coerce" x type))))
995 > ((symbol? x) (case type
996 > ((string) (symbol->string x))
997 > (else (err "Can't coerce" x type))))
998 > (#t x)))
790 999
791 < (xdef 'open-socket (lambda (num) (tcp-listen num 50 #t)))
1000 > (xdef coerce ar-coerce)
1001 >
1002 > (xdef open-socket (lambda (num) (tcp-listen num 50 #t)))
792 1003
793 1004 ; the 2050 means http requests currently capped at 2 meg
794 1005 ; http://list.cs.brown.edu/pipermail/plt-scheme/2005-August/009414.html
795 1006
796 < (xdef 'socket-accept (lambda (s)
797 < (call-with-values
1007 > (xdef socket-accept (lambda (s)
1008 > (let ((oc (current-custodian))
1009 > (nc (make-custodian)))
1010 > (current-custodian nc)
1011 > (call-with-values
798 1012 (lambda () (tcp-accept s))
799 1013 (lambda (in out)
800 < (list (make-limited-input-port in 100000 #t)
801 < out
802 < (let-values (((us them) (tcp-addresses out)))
803 < them))))))
1014 > (let ((in1 (make-limited-input-port in 100000 #t)))
1015 > (current-custodian oc)
1016 > (associate-custodian nc in1 out)
1017 > (list in1
1018 > out
1019 > (let-values (((us them) (tcp-addresses out)))
1020 > them))))))))
804 1021
805 < (xdef 'thread thread)
806 < (xdef 'kill-thread kill-thread)
807 < (xdef 'break-thread break-thread)
1022 > ; allow Arc to give up root privileges after it
1023 > ; calls open-socket. thanks, Eli!
1024 > (define setuid (get-ffi-obj 'setuid #f (_fun _int -> _int)))
1025 > (xdef setuid setuid)
1026 >
1027 > (xdef new-thread thread)
1028 > (xdef kill-thread kill-thread)
1029 > (xdef break-thread break-thread)
1030 > (xdef current-thread current-thread)
808 1031
809 1032 (define (wrapnil f) (lambda args (apply f args) 'nil))
810 1033
811 < (xdef 'sleep (wrapnil sleep))
1034 > (xdef sleep (wrapnil sleep))
812 1035
813 1036 ; Will system "execute" a half-finished string if thread killed
814 1037 ; in the middle of generating it?
815 1038
816 < (xdef 'system (wrapnil system))
1039 > (xdef system (wrapnil system))
817 1040
818 < (xdef 'pipe-from (lambda (cmd)
1041 > (xdef pipe-from (lambda (cmd)
819 1042 (let ((tf (ar-tmpname)))
820 1043 (system (string-append cmd " > " tf))
821 1044 (let ((str (open-input-file tf)))
822 1045 (system (string-append "rm -f " tf))
823 1046 str))))
824 1047
825 1048 (define (ar-tmpname)
826 1049 (call-with-input-file "/dev/urandom"
827 1050 (lambda (rstr)
828 1051 (do ((s "/tmp/")
829 1052 (c (read-char rstr) (read-char rstr))
830 1053 (i 0 (+ i 1)))
831 1054 ((>= i 16) s)
832 1055 (set! s (string-append s
833 1056 (string
834 1057 (integer->char
835 1058 (+ (char->integer #\a)
836 1059 (modulo
837 1060 (char->integer (read-char rstr))
838 1061 26))))))))))
839 1062
840 1063 ; PLT scheme provides only eq? and equal? hash tables,
841 1064 ; we need the latter for strings.
842 1065
843 < (xdef 'table (lambda () (make-hash-table 'equal)))
1066 > (xdef table (lambda args
1067 > (let ((h (make-hash-table 'equal)))
1068 > (if (pair? args) ((car args) h))
1069 > h)))
844 1070
845 < ;(xdef 'table (lambda args
1071 > ;(xdef table (lambda args
846 1072 ; (fill-table (make-hash-table 'equal)
847 1073 ; (if (pair? args) (ac-denil (car args)) '()))))
848 1074
849 1075 (define (fill-table h pairs)
850 1076 (if (eq? pairs '())
851 1077 h
852 1078 (let ((pair (car pairs)))
853 1079 (begin (hash-table-put! h (car pair) (cadr pair))
854 1080 (fill-table h (cdr pairs))))))
855 1081
856 < (xdef 'maptable (lambda (fn table) ; arg is (fn (key value) ...)
1082 > (xdef maptable (lambda (fn table) ; arg is (fn (key value) ...)
857 1083 (hash-table-for-each table fn)
858 1084 table))
859 1085
860 < (xdef 'protect (lambda (during after)
861 < (dynamic-wind (lambda () #t) during after)))
1086 > (define (protect during after)
1087 > (dynamic-wind (lambda () #t) during after))
862 1088
1089 > (xdef protect protect)
1090 >
863 1091 ; need to use a better seed
864 1092
865 < (xdef 'rand random)
1093 > (xdef rand random)
866 1094
867 < (xdef 'dir (lambda (name) (map path->string (directory-list name))))
1095 > (xdef dir (lambda (name)
1096 > (ac-niltree (map path->string (directory-list name)))))
868 1097
869 < (xdef 'file-exists (lambda (name)
1098 > ; Would def mkdir in terms of make-directory and call that instead
1099 > ; of system in ensure-dir, but make-directory is too weak: it doesn't
1100 > ; create intermediate directories like mkdir -p.
1101 >
1102 > (xdef file-exists (lambda (name)
870 1103 (if (file-exists? name) name 'nil)))
871 1104
872 < (xdef 'dir-exists (lambda (name)
1105 > (xdef dir-exists (lambda (name)
873 1106 (if (directory-exists? name) name 'nil)))
874 1107
875 < (xdef 'rmfile (wrapnil delete-file))
1108 > (xdef rmfile (wrapnil delete-file))
876 1109
1110 > (xdef mvfile (lambda (old new)
1111 > (rename-file-or-directory old new #t)
1112 > 'nil))
1113 >
877 1114 ; top level read-eval-print
878 1115 ; tle kept as a way to get a break loop when a scheme err
879 1116
880 1117 (define (arc-eval expr)
881 < (eval (ac expr '()) (interaction-environment)))
1118 > (eval (ac expr '())))
882 1119
883 1120 (define (tle)
884 1121 (display "Arc> ")
885 1122 (let ((expr (read)))
886 1123 (when (not (eqv? expr ':a))
887 1124 (write (arc-eval expr))
888 1125 (newline)
889 1126 (tle))))
890 1127
891 1128 (define last-condition* #f)
892 1129
893 1130 (define (tl)
894 1131 (display "Use (quit) to quit, (tl) to return here after an interrupt.\n")
895 1132 (tl2))
896 1133
897 1134 (define (tl2)
898 1135 (display "arc> ")
899 1136 (on-err (lambda (c)
900 1137 (set! last-condition* c)
901 1138 (display "Error: ")
902 1139 (write (exn-message c))
903 1140 (newline)
904 1141 (tl2))
905 1142 (lambda ()
906 1143 (let ((expr (read)))
907 1144 (if (eqv? expr ':a)
908 1145 'done
909 1146 (let ((val (arc-eval expr)))
910 1147 (write (ac-denil val))
911 1148 (namespace-set-variable-value! '_that val)
912 1149 (namespace-set-variable-value! '_thatexpr expr)
913 1150 (newline)
914 1151 (tl2)))))))
915 1152
916 1153 (define (aload1 p)
917 1154 (let ((x (read p)))
918 1155 (if (eof-object? x)
919 1156 #t
920 1157 (begin
921 1158 (arc-eval x)
922 1159 (aload1 p)))))
923 1160
924 1161 (define (atests1 p)
925 1162 (let ((x (read p)))
926 1163 (if (eof-object? x)
927 1164 #t
928 1165 (begin
929 1166 (write x)
930 1167 (newline)
931 1168 (let ((v (arc-eval x)))
932 1169 (if (ar-false? v)
933 1170 (begin
934 1171 (display " FAILED")
935 1172 (newline))))
936 1173 (atests1 p)))))
937 1174
938 1175 (define (aload filename)
939 1176 (call-with-input-file filename aload1))
940 1177
941 1178 (define (test filename)
942 1179 (call-with-input-file filename atests1))
943 1180
944 1181 (define (acompile1 ip op)
945 1182 (let ((x (read ip)))
946 1183 (if (eof-object? x)
947 1184 #t
948 1185 (let ((scm (ac x '())))
949 < (eval scm (interaction-environment))
1186 > (eval scm)
950 1187 (pretty-print scm op)
951 1188 (newline op)
952 1189 (newline op)
953 1190 (acompile1 ip op)))))
954 1191
955 1192 ; compile xx.arc to xx.arc.scm
956 1193 ; useful to examine the Arc compiler output
957 1194 (define (acompile inname)
958 1195 (let ((outname (string-append inname ".scm")))
959 1196 (if (file-exists? outname)
960 1197 (delete-file outname))
961 1198 (call-with-input-file inname
962 1199 (lambda (ip)
963 1200 (call-with-output-file outname
964 1201 (lambda (op)
965 1202 (acompile1 ip op)))))))
966 1203
967 < (xdef 'macex (lambda (e) (ac-macex (ac-denil e))))
1204 > (xdef macex (lambda (e) (ac-macex (ac-denil e))))
968 1205
969 < (xdef 'macex1 (lambda (e) (ac-macex (ac-denil e) 'once)))
1206 > (xdef macex1 (lambda (e) (ac-macex (ac-denil e) 'once)))
970 1207
971 < (xdef 'eval (lambda (e)
972 < (eval (ac (ac-denil e) '()) (interaction-environment))))
1208 > (xdef eval (lambda (e)
1209 > (eval (ac (ac-denil e) '()))))
973 1210
974 1211 ; If an err occurs in an on-err expr, no val is returned and code
975 1212 ; after it doesn't get executed. Not quite what I had in mind.
976 1213
977 1214 (define (on-err errfn f)
978 1215 ((call-with-current-continuation
979 1216 (lambda (k)
980 1217 (lambda ()
981 1218 (with-handlers ((exn:fail? (lambda (c)
982 1219 (k (lambda () (errfn c))))))
983 1220 (f)))))))
984 < (xdef 'on-err on-err)
1221 > (xdef on-err on-err)
985 1222
986 < (define (write-to-string x)
1223 > (define (disp-to-string x)
987 1224 (let ((o (open-output-string)))
988 < (write x o)
1225 > (display x o)
989 1226 (close-output-port o)
990 1227 (get-output-string o)))
991 1228
992 < (xdef 'details (lambda (c)
993 < (write-to-string (exn-message c))))
1229 > (xdef details (lambda (c)
1230 > (disp-to-string (exn-message c))))
994 1231
995 < (xdef 'scar (lambda (x val)
1232 > (xdef scar (lambda (x val)
996 1233 (if (string? x)
997 1234 (string-set! x 0 val)
998 < (set-car! x val))
1235 > (x-set-car! x val))
999 1236 val))
1000 1237
1001 < (xdef 'scdr (lambda (x val)
1238 > (xdef scdr (lambda (x val)
1002 1239 (if (string? x)
1003 1240 (err "Can't set cdr of a string" x)
1004 < (set-cdr! x val))
1241 > (x-set-cdr! x val))
1005 1242 val))
1243 >
1244 > ; decide at run-time whether the underlying mzscheme supports
1245 > ; set-car! and set-cdr!, since I can't figure out how to do it
1246 > ; at compile time.
1247 >
1248 > (define (x-set-car! p v)
1249 > (let ((fn (namespace-variable-value 'set-car! #t (lambda () #f))))
1250 > (if (procedure? fn)
1251 > (fn p v)
1252 > (n-set-car! p v))))
1253 >
1254 > (define (x-set-cdr! p v)
1255 > (let ((fn (namespace-variable-value 'set-cdr! #t (lambda () #f))))
1256 > (if (procedure? fn)
1257 > (fn p v)
1258 > (n-set-cdr! p v))))
1259 >
1260 > ; Eli's code to modify mzscheme-4's immutable pairs.
1261 >
1262 > ;; to avoid a malloc on every call, reuse a single pointer, but make
1263 > ;; it thread-local to avoid races
1264 > (define ptr (make-thread-cell #f))
1265 > (define (get-ptr)
1266 > (or (thread-cell-ref ptr)
1267 > (let ([p (malloc _scheme 1)]) (thread-cell-set! ptr p) p)))
1268 >
1269 > ;; set a pointer to the cons cell, then dereference it as a pointer,
1270 > ;; and bang the new value in the given offset
1271 > (define (set-ca/dr! offset who p x)
1272 > (if (pair? p)
1273 > (let ([p* (get-ptr)])
1274 > (ptr-set! p* _scheme p)
1275 > (ptr-set! (ptr-ref p* _pointer 0) _scheme offset x))
1276 > (raise-type-error who "pair" p)))
1277 >
1278 > (define (n-set-car! p x) (set-ca/dr! 1 'set-car! p x))
1279 > (define (n-set-cdr! p x) (set-ca/dr! 2 'set-cdr! p x))
1006 1280
1007 1281 ; When and if cdr of a string returned an actual (eq) tail, could
1008 1282 ; say (if (string? x) (string-replace! x val 1) ...) in scdr, but
1009 1283 ; for now would be misleading to allow this, because fails for cddr.
1010 1284
1011 1285 (define (string-replace! str val index)
1012 1286 (if (eqv? (string-length val) (- (string-length str) index))
1013 1287 (do ((i index (+ i 1)))
1014 1288 ((= i (string-length str)) str)
1015 1289 (string-set! str i (string-ref val (- i index))))
1016 1290 (err "Length mismatch between strings" str val index)))
1017 1291
1018 < (xdef 'sref (lambda (com val ind) ; later make ind rest arg
1019 < (cond ((hash-table? com) (if (eqv? val 'nil)
1020 < (hash-table-remove! com ind)
1021 < (hash-table-put! com ind val)))
1022 < ((string? com) (string-set! com ind val))
1023 < ((pair? com) (nth-set! com ind val))
1024 < (#t (err "Can't set reference " com ind val)))
1025 < val))
1292 > ; Later may want to have multiple indices.
1293 >
1294 > (xdef sref
1295 > (lambda (com val ind)
1296 > (cond ((hash-table? com) (if (eqv? val 'nil)
1297 > (hash-table-remove! com ind)
1298 > (hash-table-put! com ind val)))
1299 > ((string? com) (string-set! com ind val))
1300 > ((pair? com) (nth-set! com ind val))
1301 > (#t (err "Can't set reference " com ind val)))
1302 > val))
1026 1303
1027 1304 (define (nth-set! lst n val)
1028 < (set-car! (list-tail lst n) val))
1305 > (x-set-car! (list-tail lst n) val))
1029 1306
1030 1307 ; rewrite to pass a (true) gensym instead of #f in case var bound to #f
1031 1308
1032 1309 (define (bound? arcname)
1033 1310 (namespace-variable-value (ac-global-name arcname)
1034 1311 #t
1035 1312 (lambda () #f)))
1036 1313
1037 < (xdef 'bound (lambda (x) (if (bound? x) 't 'nil)))
1314 > (xdef bound (lambda (x) (tnil (bound? x))))
1038 1315
1039 < (xdef 'newstring make-string)
1316 > (xdef newstring make-string)
1040 1317
1041 < (xdef 'truncate (lambda (x) (inexact->exact (truncate x))))
1318 > (xdef trunc (lambda (x) (inexact->exact (truncate x))))
1042 1319
1043 < (xdef 'exact (lambda (x) (and (integer? x) (exact? x))))
1320 > ; bad name
1321 >
1322 > (xdef exact (lambda (x) (tnil (exint? x))))
1044 1323
1045 < (xdef 'msec current-milliseconds)
1046 < (xdef 'current-process-milliseconds current-process-milliseconds)
1047 < (xdef 'current-gc-milliseconds current-gc-milliseconds)
1324 > (xdef msec current-milliseconds)
1325 > (xdef current-process-milliseconds current-process-milliseconds)
1326 > (xdef current-gc-milliseconds current-gc-milliseconds)
1048 1327
1049 < (xdef 'seconds current-seconds)
1328 > (xdef seconds current-seconds)
1050 1329
1051 1330 (print-hash-table #t)
1052 1331
1053 < (xdef 'client-ip (lambda (port)
1332 > (xdef client-ip (lambda (port)
1054 1333 (let-values (((x y) (tcp-addresses port)))
1055 1334 y)))
1056 1335
1057 1336 ; make sure only one thread at a time executes anything
1058 1337 ; inside an atomic-invoke. atomic-invoke is allowed to
1059 1338 ; nest within a thread; the thread-cell keeps track of
1060 1339 ; whether this thread already holds the lock.
1061 < ; XXX make sure cell is set #f after an exception?
1062 < ; maybe it doesn't matter since thread will die?
1340 >
1063 1341 (define ar-the-sema (make-semaphore 1))
1342 >
1064 1343 (define ar-sema-cell (make-thread-cell #f))
1065 < (xdef 'atomic-invoke (lambda (f)
1344 >
1345 > (xdef atomic-invoke (lambda (f)
1066 1346 (if (thread-cell-ref ar-sema-cell)
1067 1347 (ar-apply f '())
1068 1348 (begin
1069 1349 (thread-cell-set! ar-sema-cell #t)
1070 < (let ((ret
1071 < (call-with-semaphore
1072 < ar-the-sema
1073 < (lambda () (ar-apply f '())))))
1074 < (thread-cell-set! ar-sema-cell #f)
1075 < ret)))))
1076 <
1077 < (xdef 'dead thread-dead?)
1078 <
1079 < ; Added because Mzscheme buffers output. Not sure if want as official
1080 < ; part of Arc.
1350 > (protect
1351 > (lambda ()
1352 > (call-with-semaphore
1353 > ar-the-sema
1354 > (lambda () (ar-apply f '()))))
1355 > (lambda ()
1356 > (thread-cell-set! ar-sema-cell #f)))))))
1357 >
1358 > (xdef dead (lambda (x) (tnil (thread-dead? x))))
1359 >
1360 > ; Added because Mzscheme buffers output. Not a permanent part of Arc.
1361 > ; Only need to use when declare explicit-flush optimization.
1081 1362
1082 < ;(xdef 'flushout (lambda () (flush-output) 't))
1363 > (xdef flushout (lambda () (flush-output) 't))
1083 1364
1084 < (xdef 'ssyntax (lambda (x) (if (ssyntax? x) 't 'nil)))
1365 > (xdef ssyntax (lambda (x) (tnil (ssyntax? x))))
1085 1366
1086 < (xdef 'ssexpand (lambda (x)
1367 > (xdef ssexpand (lambda (x)
1087 1368 (if (symbol? x) (expand-ssyntax x) x)))
1088 1369
1089 < (xdef 'quit exit)
1370 > (xdef quit exit)
1090 1371
1372 > ; there are two ways to close a TCP output port.
1373 > ; (close o) waits for output to drain, then closes UNIX descriptor.
1374 > ; (force-close o) discards buffered output, then closes UNIX desc.
1375 > ; web servers need the latter to get rid of connections to
1376 > ; clients that are not reading data.
1377 > ; mzscheme close-output-port doesn't work (just raises an error)
1378 > ; if there is buffered output for a non-responsive socket.
1379 > ; must use custodian-shutdown-all instead.
1091 1380
1381 > (define custodians (make-hash-table 'equal))
1382 >
1383 > (define (associate-custodian c i o)
1384 > (hash-table-put! custodians i c)
1385 > (hash-table-put! custodians o c))
1386 >
1387 > ; if a port has a custodian, use it to close the port forcefully.
1388 > ; also get rid of the reference to the custodian.
1389 > ; sadly doing this to the input port also kills the output port.
1390 >
1391 > (define (try-custodian p)
1392 > (let ((c (hash-table-get custodians p #f)))
1393 > (if c
1394 > (begin
1395 > (custodian-shutdown-all c)
1396 > (hash-table-remove! custodians p)
1397 > #t)
1398 > #f)))
1399 >
1400 > (define (ar-close . args)
1401 > (map (lambda (p)
1402 > (cond ((input-port? p) (close-input-port p))
1403 > ((output-port? p) (close-output-port p))
1404 > ((tcp-listener? p) (tcp-close p))
1405 > (#t (err "Can't close " p))))
1406 > args)
1407 > (map (lambda (p) (try-custodian p)) args) ; free any custodian
1408 > 'nil)
1409 >
1410 > (xdef close ar-close)
1411 >
1412 > (xdef force-close (lambda args
1413 > (map (lambda (p)
1414 > (if (not (try-custodian p))
1415 > (ar-close p)))
1416 > args)
1417 > 'nil))
1418 >
1419 > (xdef memory current-memory-use)
1420 >
1421 > (xdef declare (lambda (key val)
1422 > (let ((flag (not (ar-false? val))))
1423 > (case key
1424 > ((atstrings) (set! atstrings flag))
1425 > ((direct-calls) (set! direct-calls flag))
1426 > ((explicit-flush) (set! explicit-flush flag)))
1427 > val)))
1428 >
1429 > (putenv "TZ" ":GMT")
1430 >
1431 > (define (gmt-date sec) (seconds->date sec))
1432 >
1433 > (xdef timedate
1434 > (lambda args
1435 > (let ((d (gmt-date (if (pair? args) (car args) (current-seconds)))))
1436 > (ac-niltree (list (date-second d)
1437 > (date-minute d)
1438 > (date-hour d)
1439 > (date-day d)
1440 > (date-month d)
1441 > (date-year d))))))
1442 >
1443 > (xdef sin sin)
1444 > (xdef cos cos)
1445 > (xdef tan tan)
1446 > (xdef asin asin)
1447 > (xdef acos acos)
1448 > (xdef atan atan)
1449 > (xdef log log)
1450 >
1451 > (define (codestring s)
1452 > (let ((i (atpos s 0)))
1453 > (if i
1454 > (cons (substring s 0 i)
1455 > (let* ((rest (substring s (+ i 1)))
1456 > (in (open-input-string rest))
1457 > (expr (read in))
1458 > (i2 (let-values (((x y z) (port-next-location in))) z)))
1459 > (close-input-port in)
1460 > (cons expr (codestring (substring rest (- i2 1))))))
1461 > (list s))))
1462 >
1463 > ; First unescaped @ in s, if any. Escape by doubling.
1464 >
1465 > (define (atpos s i)
1466 > (cond ((eqv? i (string-length s))
1467 > #f)
1468 > ((eqv? (string-ref s i) #\@)
1469 > (if (and (< (+ i 1) (string-length s))
1470 > (not (eqv? (string-ref s (+ i 1)) #\@)))
1471 > i
1472 > (atpos s (+ i 2))))
1473 > (#t
1474 > (atpos s (+ i 1)))))
1475 >
1476 > (define (unescape-ats s)
1477 > (list->string (letrec ((unesc (lambda (cs)
1478 > (cond
1479 > ((null? cs)
1480 > '())
1481 > ((and (eqv? (car cs) #\@)
1482 > (not (null? (cdr cs)))
1483 > (eqv? (cadr cs) #\@))
1484 > (unesc (cdr cs)))
1485 > (#t
1486 > (cons (car cs) (unesc (cdr cs))))))))
1487 > (unesc (string->list s)))))
1488 >
1092 1489 )
1093 1490
1094 < (require ac)
1095 1491
================================================================================
app.arc
================================================================================
1097 1493 ; Application Server. Layer inserted 2 Sep 06.
1098 1494
1099 < ; todo: def a general notion of apps of which the programming app is
1100 < ; one and the news site another.
1495 > ; ideas:
1496 > ; def a general notion of apps of which prompt is one, news another
1101 1497 ; give each user a place to store data? A home dir?
1102 1498
1103 1499 ; A user is simply a string: "pg". Use /whoami to test user cookie.
1104 1500
1105 1501 (= hpwfile* "arc/hpw"
1502 > oidfile* "arc/openids"
1106 1503 adminfile* "arc/admins"
1107 1504 cookfile* "arc/cooks")
1108 1505
1109 1506 (def asv ((o port 8080))
1110 1507 (load-userinfo)
1111 1508 (serve port))
1112 1509
1113 1510 (def load-userinfo ()
1114 1511 (= hpasswords* (safe-load-table hpwfile*)
1512 > openids* (safe-load-table oidfile*)
1115 1513 admins* (map string (errsafe (readfile adminfile*)))
1116 1514 cookie->user* (safe-load-table cookfile*))
1117 1515 (maptable (fn (k v) (= (user->cookie* v) k))
1118 1516 cookie->user*))
1119 1517
1120 1518 ; idea: a bidirectional table, so don't need two vars (and sets)
1121 1519
1122 1520 (= cookie->user* (table) user->cookie* (table) logins* (table))
1123 1521
1124 1522 (def get-user (req)
1125 < (let u (aand (alref (req 'cooks) "user") (cookie->user* (sym it)))
1126 < (when u (= (logins* u) (req 'ip)))
1523 > (let u (aand (alref req!cooks "user") (cookie->user* (sym it)))
1524 > (when u (= (logins* u) req!ip))
1127 1525 u))
1128 1526
1129 < (mac when-usermatch (user req . body)
1527 > (mac when-umatch (user req . body)
1130 1528 `(if (is ,user (get-user ,req))
1131 1529 (do ,@body)
1132 1530 (mismatch-message)))
1133 1531
1134 < (def mismatch-message () (prn "Dead link: users don't match."))
1532 > (def mismatch-message ()
1533 > (prn "Dead link: users don't match."))
1135 1534
1136 < (mac when-usermatchr (user req . body)
1535 > (mac when-umatch/r (user req . body)
1137 1536 `(if (is ,user (get-user ,req))
1138 1537 (do ,@body)
1139 1538 "mismatch"))
1140 1539
1141 1540 (defop mismatch req (mismatch-message))
1142 1541
1143 < (mac matchform (user req after . body)
1542 > (mac uform (user req after . body)
1144 1543 `(aform (fn (,req)
1145 < (when-usermatch ,user ,req
1544 > (when-umatch ,user ,req
1146 1545 ,after))
1147 1546 ,@body))
1148 1547
1149 < (mac matchrform (user req after . body)
1548 > (mac urform (user req after . body)
1150 1549 `(arform (fn (,req)
1151 < (when-usermatchr ,user ,req
1550 > (when-umatch/r ,user ,req
1152 1551 ,after))
1153 1552 ,@body))
1154 1553
1155 1554 ; Like onlink, but checks that user submitting the request is the
1156 < ; same it was generated for. Really should log the username and
1157 < ; ip addr of every genlink, and check if they match.
1555 > ; same it was generated for. For extra protection could log the
1556 > ; username and ip addr of every genlink, and check if they match.
1158 1557
1159 < (mac userlink (user text . body)
1558 > (mac ulink (user text . body)
1160 1559 (w/uniq req
1161 1560 `(linkf ,text (,req)
1162 < (when-usermatch ,user ,req ,@body))))
1561 > (when-umatch ,user ,req ,@body))))
1163 1562
1164 1563
1165 1564 (defop admin req (admin-gate (get-user req)))
1166 1565
1167 1566 (def admin-gate (u)
1168 1567 (if (admin u)
1169 1568 (admin-page u)
1170 1569 (login-page 'login nil
1171 1570 (fn (u ip) (admin-gate u)))))
1172 1571
1173 1572 (def admin (u) (and u (mem u admins*)))
1174 1573
1175 1574 (def user-exists (u) (and u (hpasswords* u) u))
1176 1575
1177 1576 (def admin-page (user . msg)
1178 1577 (whitepage
1179 1578 (prbold "Admin: ")
1180 1579 (hspace 20)
1181 1580 (pr user " | ")
1182 1581 (w/link (do (logout-user user)
1183 1582 (whitepage (pr "Bye " user ".")))
1184 1583 (pr "logout"))
1185 1584 (when msg (hspace 10) (map pr msg))
1186 1585 (br2)
1187 1586 (aform (fn (req)
1188 < (when-usermatch user req
1587 > (when-umatch user req
1189 1588 (with (u (arg req "u") p (arg req "p"))
1190 1589 (if (or (no u) (no p) (is u "") (is p ""))
1191 1590 (pr "Bad data.")
1192 1591 (user-exists u)
1193 1592 (admin-page user "User already exists: " u)
1194 1593 (do (create-acct u p)
1195 1594 (admin-page user))))))
1196 1595 (pwfields "create (server) account"))))
1197 <
1198 < ; need to define a notion of a hashtable that's always written
1199 < ; to a file when modified
1200 1596
1201 1597 (def cook-user (user)
1202 1598 (let id (new-user-cookie)
1203 1599 (= (cookie->user* id) user
1204 1600 (user->cookie* user) id)
1205 1601 (save-table cookie->user* cookfile*)
1206 1602 id))
1207 1603
1208 1604 ; Unique-ids are only unique per server invocation.
1209 1605
1210 1606 (def new-user-cookie ()
1211 1607 (let id (unique-id)
1212 1608 (if (cookie->user* id) (new-user-cookie) id)))
1213 1609
1214 1610 (def logout-user (user)
1215 < (nil! (logins* user))
1216 < (nil! (cookie->user* (user->cookie* user)) (user->cookie* user))
1611 > (wipe (logins* user))
1612 > (wipe (cookie->user* (user->cookie* user)) (user->cookie* user))
1217 1613 (save-table cookie->user* cookfile*))
1218 1614
1219 1615 (def create-acct (user pw)
1616 > (set (dc-usernames* (downcase user)))
1220 1617 (set-pw user pw))
1221 1618
1222 1619 (def disable-acct (user)
1223 1620 (set-pw user (rand-string 20))
1224 1621 (logout-user user))
1225 1622
1226 1623 (def set-pw (user pw)
1227 1624 (= (hpasswords* user) (and pw (shash pw)))
1228 1625 (save-table hpasswords* hpwfile*))
1229 1626
1230 1627 (def hello-page (user ip)
1231 1628 (whitepage (prs "hello" user "at" ip)))
1232 1629
1233 1630 (defop login req (login-page 'login))
1234 1631
1235 1632 ; switch is one of: register, login, both
1236 < ; afterward is a function on the newly created user, ip addr
1237 < ; or can be a list of such a fn and a string, in which case call fn
1238 < ; then redirect to string
1633 >
1634 > ; afterward is either a function on the newly created username and
1635 > ; ip address, in which case it is called to generate the next page
1636 > ; after a successful login, or a pair of (function url), which means
1637 > ; call the function, then redirect to the url.
1239 1638
1240 1639 ; classic example of something that should just "return" a val
1241 1640 ; via a continuation rather than going to a new page.
1242 1641
1243 < ; ugly code-- too much duplication
1244 <
1245 1642 (def login-page (switch (o msg nil) (o afterward hello-page))
1246 1643 (whitepage
1247 1644 (pagemessage msg)
1248 1645 (when (in switch 'login 'both)
1249 < (prbold "Login")
1250 < (br2)
1251 < (if (acons afterward)
1252 < (let (f url) afterward
1253 < (arformh (fn (req)
1254 < (logout-user (get-user req))
1255 < (aif (good-login (arg req "u") (arg req "p") (req 'ip))
1256 < (do (= (logins* it) (req 'ip))
1257 < (prcookie (user->cookie* it))
1258 < (f it (req 'ip))
1259 < url)
1260 < (flink (fn ignore (login-page switch
1261 < "Bad login."
1262 < afterward)))))
1263 < (pwfields)))
1264 < (aformh (fn (req)
1265 < (logout-user (get-user req))
1266 < (aif (good-login (arg req "u") (arg req "p") (req 'ip))
1267 < (do (= (logins* it) (req 'ip))
1268 < (prcookie (user->cookie* it))
1269 < (prn)
1270 < (afterward it (req 'ip)))
1271 < (do (prn)
1272 < (login-page switch "Bad login." afterward))))
1273 < (pwfields)))
1646 > (login-form "Login" switch login-handler afterward)
1647 > (hook 'login-form afterward)
1274 1648 (br2))
1275 1649 (when (in switch 'register 'both)
1276 < (prbold "Create Account")
1277 < (br2)
1278 < (if (acons afterward)
1279 < (let (f url) afterward
1280 < (arformh (fn (req)
1281 < (logout-user (get-user req))
1282 < (with (user (arg req "u") pw (arg req "p"))
1283 < (aif (bad-newacct user pw)
1284 < (flink (fn ignore
1285 < (login-page switch it afterward)))
1286 < (do (create-acct user pw)
1287 < (= (logins* user) (req 'ip))
1288 < (prcookie (cook-user user))
1289 < (f user (req 'ip))
1290 < url))))
1291 < (pwfields "create account")))
1292 < (aformh (fn (req)
1293 < (logout-user (get-user req))
1294 < (with (user (arg req "u") pw (arg req "p"))
1295 < (aif (bad-newacct user pw)
1296 < (do (prn)
1297 < (login-page switch it afterward))
1298 < (do (create-acct user pw)
1299 < (= (logins* user) (req 'ip))
1300 < (prcookie (cook-user user))
1301 < (prn)
1302 < (afterward user (req 'ip))))))
1303 < (pwfields "create account"))))))
1304 <
1650 > (login-form "Create Account" switch create-handler afterward))))
1651 >
1652 > (def login-form (label switch handler afterward)
1653 > (prbold label)
1654 > (br2)
1655 > (fnform (fn (req) (handler req switch afterward))
1656 > (fn () (pwfields (downcase label)))
1657 > (acons afterward)))
1658 >
1659 > (def login-handler (req switch afterward)
1660 > (logout-user (get-user req))
1661 > (aif (good-login (arg req "u") (arg req "p") req!ip)
1662 > (login it req!ip (user->cookie* it) afterward)
1663 > (failed-login switch "Bad login." afterward)))
1664 >
1665 > (def create-handler (req switch afterward)
1666 > (logout-user (get-user req))
1667 > (with (user (arg req "u") pw (arg req "p"))
1668 > (aif (bad-newacct user pw)
1669 > (failed-login switch it afterward)
1670 > (do (create-acct user pw)
1671 > (login user req!ip (cook-user user) afterward)))))
1672 >
1673 > (def login (user ip cookie afterward)
1674 > (= (logins* user) ip)
1675 > (prcookie cookie)
1676 > (if (acons afterward)
1677 > (let (f url) afterward
1678 > (f user ip)
1679 > url)
1680 > (do (prn)
1681 > (afterward user ip))))
1682 >
1683 > (def failed-login (switch msg afterward)
1684 > (if (acons afterward)
1685 > (flink (fn ignore (login-page switch msg afterward)))
1686 > (do (prn)
1687 > (login-page switch msg afterward))))
1688 >
1305 1689 (def prcookie (cook)
1306 1690 (prn "Set-Cookie: user=" cook "; expires=Sun, 17-Jan-2038 19:14:07 GMT"))
1307 1691
1308 1692 (def pwfields ((o label "login"))
1309 1693 (inputs u username 20 nil
1310 1694 p password 20 nil)
1311 1695 (br)
1312 1696 (submit label))
1313 1697
1314 1698 (= good-logins* (queue) bad-logins* (queue))
1315 1699
1316 1700 (def good-login (user pw ip)
1317 < (let record (list (seconds) ip user pw)
1701 > (let record (list (seconds) ip user)
1318 1702 (if (and user pw (aand (shash pw) (is it (hpasswords* user))))
1319 1703 (do (unless (user->cookie* user) (cook-user user))
1320 1704 (enq-limit record good-logins*)
1321 1705 user)
1322 1706 (do (enq-limit record bad-logins*)
1323 1707 nil))))
1324 1708
1325 < ; can remove this once sha1 installed on pi
1326 <
1327 1709 ; Create a file in case people have quote chars in their pws. I can't
1328 1710 ; believe there's no way to just send the chars.
1329 1711
1330 1712 (def shash (str)
1331 1713 (let fname (+ "/tmp/shash" (rand-string 10))
1332 1714 (w/outfile f fname (disp str f))
1333 1715 (let res (tostring (system (+ "openssl dgst -sha1 <" fname)))
1334 < (do1 (subseq res 0 (- (len res) 1))
1716 > (do1 (cut res 0 (- (len res) 1))
1335 1717 (rmfile fname)))))
1336 1718
1719 > (= dc-usernames* (table))
1720 >
1721 > (def username-taken (user)
1722 > (when (empty dc-usernames*)
1723 > (each (k v) hpasswords*
1724 > (set (dc-usernames* (downcase k)))))
1725 > (dc-usernames* (downcase user)))
1726 >
1337 1727 (def bad-newacct (user pw)
1338 1728 (if (no (goodname user 2 15))
1339 1729 "Usernames can only contain letters, digits, dashes and
1340 1730 underscores, and should be between 2 and 15 characters long.
1341 1731 Please choose another."
1342 < (let dcuser (downcase user)
1343 < (some [is dcuser (downcase _)] (keys hpasswords*)))
1732 > (username-taken user)
1344 1733 "That username is taken. Please choose another."
1345 1734 (or (no pw) (< (len pw) 4))
1346 1735 "Passwords should be a least 4 characters long. Please
1347 1736 choose another."
1348 1737 nil))
1349 1738
1350 1739 (def goodname (str (o min 1) (o max nil))
1351 1740 (and (isa str 'string)
1352 1741 (>= (len str) min)
1353 1742 (~find (fn (c) (no (or (alphadig c) (in c #\- #\_))))
1354 1743 str)
1355 1744 (isnt (str 0) #\-)
1356 1745 (or (no max) (<= (len str) max))
1357 1746 str))
1358 1747
1359 <
1360 1748 (defop logout req
1361 1749 (aif (get-user req)
1362 1750 (do (logout-user it)
1363 1751 (pr "Logged out."))
1364 1752 (pr "You were not logged in.")))
1365 1753
1366 1754 (defop whoami req
1367 1755 (aif (get-user req)
1368 < (prs it 'at (req 'ip))
1756 > (prs it 'at req!ip)
1369 1757 (do (pr "You are not logged in. ")
1370 1758 (w/link (login-page 'both) (pr "Log in"))
1371 1759 (pr "."))))
1372 1760
1373 1761
1374 <
1375 < (= formwid* 60 bigformwid* 80 numwid* 8 formatdoc-url* nil)
1762 > (= formwid* 60 bigformwid* 80 numwid* 16 formatdoc-url* nil)
1376 1763
1377 1764 ; Eventually figure out a way to separate type name from format of
1378 1765 ; input field, instead of having e.g. toks and bigtoks
1379 1766
1380 1767 (def varfield (typ id val)
1381 1768 (if (in typ 'string 'string1 'url)
1382 1769 (gentag input type 'text name id value val size formwid*)
1383 < (in typ 'num 'int 'posint)
1770 > (in typ 'num 'int 'posint 'sym)
1384 1771 (gentag input type 'text name id value val size numwid*)
1385 1772 (in typ 'users 'toks)
1386 1773 (gentag input type 'text name id value (tostring (apply prs val))
1387 1774 size formwid*)
1388 1775 (is typ 'sexpr)
1389 1776 (gentag input type 'text name id
1390 1777 value (tostring (map [do (write _) (sp)] val))
1391 1778 size formwid*)
1392 1779 (in typ 'syms 'text 'doc 'mdtext 'mdtext2 'lines 'bigtoks)
1393 1780 (let text (if (in typ 'syms 'bigtoks)
1394 1781 (tostring (apply prs val))
1782 > (is typ 'lines)
1783 > (tostring (apply pr (intersperse #\newline val)))
1395 1784 (in typ 'mdtext 'mdtext2)
1396 1785 (unmarkdown val)
1397 1786 (no val)
1398 1787 ""
1399 1788 val)
1400 1789 (tag (textarea cols (if (is typ 'doc) bigformwid* formwid*)
1401 1790 rows (needrows text formwid* 4)
1402 1791 wrap 'virtual
1403 1792 style (if (is typ 'doc) "font-size:8.5pt")
1404 1793 name id)
1405 1794 (prn) ; needed or 1 initial newline gets chopped off
1406 1795 (pr text))
1407 1796 (when (and formatdoc-url* (in typ 'mdtext 'mdtext2))
1408 1797 (pr " ")
1409 1798 (tag (font size -2)
1410 1799 (link "help" formatdoc-url* (gray 175)))))
1411 < (and (acons typ) (is (car typ) 'choice))
1800 > (caris typ 'choice)
1412 1801 (menu id (cddr typ) val)
1413 1802 (is typ 'yesno)
1414 1803 (menu id '("yes" "no") (if val "yes" "no"))
1415 1804 (is typ 'hexcol)
1416 < (gentag input type 'text name id value val); was (hexrep val)
1805 > (gentag input type 'text name id value val)
1806 > (is typ 'time)
1807 > (gentag input type 'text name id value (if val (english-time val) ""))
1808 > (is typ 'date)
1809 > (gentag input type 'text name id value (if val (english-date val) ""))
1417 1810 (err "unknown varfield type" typ)))
1418 1811
1419 1812 (def text-rows (text wid (o pad 3))
1420 < (+ (truncate (/ (len text) (* wid .8))) pad))
1813 > (+ (trunc (/ (len text) (* wid .8))) pad))
1421 1814
1422 1815 (def needrows (text cols (o pad 0))
1423 1816 (+ pad (max (+ 1 (count #\newline text))
1424 1817 (roundup (/ (len text) (- cols 5))))))
1425 1818
1426 < (def varline (typ id val)
1819 > (def varline (typ id val (o liveurls))
1427 1820 (if (in typ 'users 'syms 'toks 'bigtoks) (apply prs val)
1428 1821 (is typ 'lines) (map prn val)
1429 1822 (is typ 'yesno) (pr (if val 'yes 'no))
1430 < (is typ 'choice) (varline (cadr typ) nil val)
1823 > (caris typ 'choice) (varline (cadr typ) nil val)
1824 > (is typ 'url) (if (and liveurls (valid-url val))
1825 > (link val val)
1826 > (pr val))
1431 1827 (text-type typ) (pr (or val ""))
1432 1828 (pr val)))
1433 1829
1434 1830 (def text-type (typ) (in typ 'string 'string1 'url 'text 'mdtext 'mdtext2))
1435 1831
1436 1832 ; Newlines in forms come back as /r/n. Only want the /ns. Currently
1437 1833 ; remove the /rs in individual cases below. Could do it in aform or
1438 1834 ; even in the parsing of http requests, in the server.
1439 1835
1440 1836 ; Need the calls to striptags so that news users can't get html
1441 1837 ; into a title or comment by editing it. If want a form that
1442 1838 ; can take html, just create another typ for it.
1443 1839
1444 1840 (def readvar (typ str (o fail nil))
1445 1841 (case (carif typ)
1446 1842 string (striptags str)
1447 < string1 (if (is str "") fail (striptags str))
1448 < url (if (is str "") str (valid-url str) (striptags str) fail)
1843 > string1 (if (blank str) fail (striptags str))
1844 > url (if (blank str) "" (valid-url str) (clean-url str) fail)
1449 1845 num (let n (saferead str) (if (number n) n fail))
1450 1846 int (let n (saferead str)
1451 1847 (if (number n) (round n) fail))
1452 1848 posint (let n (saferead str)
1453 1849 (if (and (number n) (> n 0)) (round n) fail))
1454 1850 text (striptags str)
1455 1851 doc (striptags str)
1456 1852 mdtext (md-from-form str)
1457 1853 mdtext2 (md-from-form str t) ; for md with no links
1458 < ; sym (aif (tokens str) (sym (car it)) fail)
1459 < ; syms (map sym (tokens str))
1854 > sym (or (sym:car:tokens str) fail)
1855 > syms (map sym (tokens str))
1460 1856 sexpr (errsafe (readall str))
1461 1857 users (rem [no (goodname _)] (tokens str))
1462 1858 toks (tokens str)
1463 1859 bigtoks (tokens str)
1464 < ; lines (or (splitlines (= sss str)) fail)
1860 > lines (lines str)
1465 1861 choice (readvar (cadr typ) str)
1466 1862 yesno (is str "yes")
1467 < hexcol (if (hex>color str) str fail) ; was (or (hex>color str) fail)
1863 > hexcol (if (hex>color str) str fail)
1864 > time (or (errsafe (parse-time str)) fail)
1865 > date (or (errsafe (parse-date str)) fail)
1468 1866 (err "unknown readvar type" typ)))
1469 1867
1470 < (def splitlines (str)
1471 < (map [rem #\return _] (split (cons #\newline "") str)))
1868 > ; dates should be tagged date, and just redefine <
1869 >
1870 > (def varcompare (typ)
1871 > (if (in typ 'syms 'sexpr 'users 'toks 'bigtoks 'lines 'hexcol)
1872 > (fn (x y) (> (len x) (len y)))
1873 > (is typ 'date)
1874 > (fn (x y)
1875 > (or (no y) (and x (date< x y))))
1876 > (fn (x y)
1877 > (or (empty y) (and (~empty x) (< x y))))))
1878 >
1472 1879
1473 < (= fail* (uniq))
1880 > ; (= fail* (uniq))
1881 >
1882 > (def fail* ()) ; coudn't possibly come back from a form
1474 1883
1475 1884 ; Takes a list of fields of the form (type label value view modify) and
1476 1885 ; a fn f and generates a form such that when submitted (f label newval)
1477 1886 ; will be called for each valid value. Finally done is called.
1478 1887
1479 1888 (def vars-form (user fields f done (o button "update") (o lasts))
1480 < (timed-aform lasts
1481 < (fn (req)
1482 < (when-usermatch user req
1483 < (each (k v) (req 'args)
1484 < (let name (sym k)
1485 < (awhen (find [is (cadr _) name] fields)
1486 < (let (typ id val mod) it
1487 < (when (and mod v)
1488 < (let newval (readvar typ v fail*)
1489 < (unless (is newval fail*)
1490 < (f name newval))))))))
1491 < (done)))
1889 > (taform lasts
1890 > (if (all [no (_ 4)] fields)
1891 > (fn (req))
1892 > (fn (req)
1893 > (when-umatch user req
1894 > (each (k v) req!args
1895 > (let name (sym k)
1896 > (awhen (find [is (cadr _) name] fields)
1897 > ; added sho to fix bug
1898 > (let (typ id val sho mod) it
1899 > (when (and mod v)
1900 > (let newval (readvar typ v fail*)
1901 > (unless (is newval fail*)
1902 > (f name newval))))))))
1903 > (done))))
1492 1904 (tab
1493 1905 (showvars fields))
1494 1906 (unless (all [no (_ 4)] fields) ; no modifiable fields
1495 1907 (br)
1496 1908 (submit button))))
1497 1909
1498 < (def showvars (fields)
1910 > (def showvars (fields (o liveurls))
1499 1911 (each (typ id val view mod question) fields
1500 1912 (when view
1501 1913 (when question
1502 1914 (tr (td (prn question))))
1503 1915 (tr (unless question (tag (td valign 'top) (pr id ":")))
1504 < (td ((if mod varfield varline) typ id val)))
1916 > (td (if mod
1917 > (varfield typ id val)
1918 > (varline typ id val liveurls))))
1505 1919 (prn))))
1506 1920
1507 1921 ; http://daringfireball.net/projects/markdown/syntax
1508 1922
1509 1923 (def md-from-form (str (o nolinks))
1510 < (markdown (trim (rem #\return (esc<>& str)) 'end) 60 nolinks))
1924 > (markdown (trim (rem #\return (esc-tags str)) 'end) 60 nolinks))
1511 1925
1512 1926 (def markdown (s (o maxurl) (o nolinks))
1513 1927 (let ital nil
1514 1928 (tostring
1515 1929 (forlen i s
1516 1930 (iflet (newi spaces) (indented-code s i (if (is i 0) 2 0))
1517 1931 (do (pr "
")
1518 1932 (let cb (code-block s (- newi spaces 1))
1519 1933 (pr cb)
1520 1934 (= i (+ (- newi spaces 1) (len cb))))
1521 1935 (pr ""))
1524 1938 (= i (- newi 1)))
1525 1939 (and (is (s i) #\*)
1526 1940 (or ital
1527 1941 (atend i s)
1528 1942 (and (~whitec (s (+ i 1)))
1529 1943 (pos #\* s (+ i 1)))))
1530 1944 (do (pr (if ital "" ""))
1531 1945 (= ital (no ital)))
1532 1946 (and (no nolinks)
1533 < (t! gotthere)
1534 1947 (or (litmatch "http://" s i)
1535 1948 (litmatch "https://" s i)))
1536 1949 (withs (n (urlend s i)
1537 < url (subseq s i n))
1950 > url (clean-url (cut s i n)))
1538 1951 (tag (a href url rel 'nofollow)
1539 1952 (pr (if (no maxurl) url (ellipsize url maxurl))))
1540 1953 (= i (- n 1)))
1541 1954 (writec (s i))))))))
1542 1955
1543 1956 (def indented-code (s i (o newlines 0) (o spaces 0))
1544 1957 (let c (s i)
1545 1958 (if (nonwhite c)
1546 1959 (if (and (> newlines 1) (> spaces 1))
1547 1960 (list i spaces)
1548 1961 nil)
1549 1962 (atend i s)
1550 1963 nil
1551 1964 (is c #\newline)
1552 1965 (indented-code s (+ i 1) (+ newlines 1) 0)
1553 1966 (indented-code s (+ i 1) newlines (+ spaces 1)))))
1554 1967
1968 > ; If i is start a paragraph break, returns index of start of next para.
1969 >
1555 1970 (def parabreak (s i (o newlines 0))
1556 1971 (let c (s i)
1557 1972 (if (or (nonwhite c) (atend i s))
1558 1973 (if (> newlines 1) i nil)
1559 1974 (parabreak s (+ i 1) (+ newlines (if (is c #\newline) 1 0))))))
1560 <
1975 >
1976 > ; Returns the indices of the next paragraph break in s, if any.
1561 1977
1978 > (def next-parabreak (s i)
1979 > (unless (atend i s)
1980 > (aif (parabreak s i)
1981 > (list i it)
1982 > (next-parabreak s (+ i 1)))))
1983 >
1984 > (def paras (s (o i 0))
1985 > (if (atend i s)
1986 > nil
1987 > (iflet (endthis startnext) (next-parabreak s i)
1988 > (cons (cut s i endthis)
1989 > (paras s startnext))
1990 > (list (trim (cut s i) 'end)))))
1991 >
1992 >
1562 1993 ; Returns the index of the first char not part of the url beginning
1563 1994 ; at i, or len of string if url goes all the way to the end.
1564 1995
1565 1996 ; Note that > immediately after a url (http://foo.com>) will cause
1566 1997 ; an odd result, because the > gets escaped to something beginning
1567 1998 ; with &, which is treated as part of the url. Perhaps the answer
1568 < ; is just to esc<>& after markdown instead of before.
1999 > ; is just to esc-tags after markdown instead of before.
1569 2000
1570 < (def urlend (s i)
2001 > ; Treats a delimiter as part of a url if it is (a) an open delimiter
2002 > ; not followed by whitespace or eos, or (b) a close delimiter
2003 > ; balancing a previous open delimiter.
2004 >
2005 > (def urlend (s i (o indelim))
1571 2006 (let c (s i)
1572 2007 (if (atend i s)
1573 < (if ((orf punc delimc whitec) c) i (+ i 1))
2008 > (if ((orf punc whitec opendelim) c)
2009 > i
2010 > (closedelim c)
2011 > (if indelim (+ i 1) i)
2012 > (+ i 1))
1574 2013 (if (or (whitec c)
1575 < (delimc c)
1576 < (and (punc c)
1577 < ((orf whitec delimc) (s (+ i 1)))))
2014 > (and (punc c) (whitec (s (+ i 1))))
2015 > (and ((orf whitec punc) (s (+ i 1)))
2016 > (or (opendelim c)
2017 > (and (closedelim c) (no indelim)))))
1578 2018 i
1579 < (urlend s (+ i 1))))))
1580 <
1581 < (def delimc (c)
1582 < (in c #\( #\) #\[ #\] #\{ #\} #\"))
2019 > (urlend s (+ i 1) (or (opendelim c)
2020 > (and indelim (no (closedelim c)))))))))
2021 >
2022 > (def opendelim (c) (in c #\< #\( #\[ #\{))
2023 >
2024 > (def closedelim (c) (in c #\> #\) #\] #\}))
1583 2025
1584 2026
1585 2027 (def code-block (s i)
1586 2028 (tostring
1587 2029 (until (let left (- (len s) i 1)
1588 2030 (or (is left 0)
1589 2031 (and (> left 2)
1590 2032 (is (s (+ i 1)) #\newline)
1591 2033 (nonwhite (s (+ i 2))))))
1592 2034 (writec (s (++ i))))))
1593 2035
1594 2036 (def unmarkdown (s)
1595 2037 (tostring
1596 2038 (forlen i s
1597 2039 (if (litmatch "
" s i)
1598 2040 (do (++ i 2)
1599 2041 (unless (is i 2) (pr "\n\n")))
1600 2042 (litmatch "" s i)
1601 2043 (do (++ i 2) (pr #\*))
1602 2044 (litmatch " " s i)
1603 2045 (do (++ i 3) (pr #\*))
1604 2046 (litmatch "" s endurl)
1609 2051 (+ it 3)
1610 2052 endurl)))
1611 2053 (writec (s i))))
1612 2054 (litmatch "" s i)
1613 2055 (awhen (findsubseq "" s i)
1617 < (awhen (findsubseq ""))
3725 < (nil! ink))))))
4488 > (wipe ink))))))
3726 4489
3727 4490 (mac spanclass (name . body)
3728 4491 `(tag (span class ',name) ,@body))
3729 4492
3730 4493 (def pagemessage (text)
3731 4494 (when text (prn text) (br2)))
4495 >
4496 > ; Could be stricter. Memoized because looking for chars in Unicode
4497 > ; strings is terribly inefficient in Mzscheme.
4498 >
4499 > (defmemo valid-url (url)
4500 > (and (len> url 10)
4501 > (or (begins url "http://")
4502 > (begins url "https://"))
4503 > (~find [in _ #\< #\> #\" #\'] url)))
4504 >
4505 > (mac fontcolor (c . body)
4506 > (w/uniq g
4507 > `(let ,g ,c
4508 > (if ,g
4509 > (tag (font color ,g) ,@body)
4510 > (do ,@body)))))
3732 4511
================================================================================
libs.arc
================================================================================
3734 4513 (map load '("strings.arc"
3735 4514 "pprint.arc"
3736 4515 "code.arc"
3737 4516 "html.arc"
3738 4517 "srv.arc"
3739 4518 "app.arc"
3740 4519 "prompt.arc"))
3741 4520
================================================================================
pprint.arc
================================================================================
3743 4522 ; Pretty-Printing. Spun off 4 Aug 06.
3744 4523
3745 4524 ; todo: indentation of long ifs; quasiquote, unquote, unquote-splicing
3746 4525
3747 4526 (= bodops* (fill-table (table)
3748 4527 '(let 2 with 1 while 1 def 2 fn 1 rfn 2 afn 1
3749 4528 when 1 unless 1 after 1 whilet 2 for 3 each 2 whenlet 2 awhen 1
3750 4529 whitepage 0 tag 1 form 1 aform 1 aformh 1 w/link 1 textarea 3
3751 4530 )))
3752 4531
3753 4532 (= oneline* 35) ; print exprs less than this long on one line
3754 4533
3755 4534 ; If returns nil, can assume it didn't have to break expr.
3756 4535
3757 4536 (def ppr (expr (o col 0) (o noindent nil))
3758 4537 (if (or (atom expr) (dotted expr))
3759 4538 (do (unless noindent (sp col))
3760 4539 (write expr)
3761 4540 nil)
3762 4541 (is (car expr) 'quote)
3763 4542 (do (unless noindent (sp col))
3764 4543 (pr "'")
3765 4544 (ppr (cadr expr) (+ col 1) t))
3766 4545 (bodops* (car expr))
3767 4546 (do (unless noindent (sp col))
3768 4547 (let whole (tostring (write expr))
3769 4548 (if (< (len whole) oneline*)
3770 4549 (do (pr whole) nil)
3771 4550 (ppr-progn expr col noindent))))
3772 4551 (do (unless noindent (sp col))
3773 4552 (let whole (tostring (write expr))
3774 4553 (if (< (len whole) oneline*)
3775 4554 (do (pr whole) nil)
3776 4555 (ppr-call expr col noindent))))))
3777 4556
3778 4557 (def ppr-progn (expr col noindent)
3779 4558 (lpar)
3780 4559 (let n (bodops* (car expr))
3781 4560 (let str (tostring (write-spaced (firstn n expr)))
3782 4561 (unless (is n 0) (pr str) (sp))
3783 4562 (ppr (expr n) (+ col (len str) 2) t))
3784 4563 (map (fn (e) (prn) (ppr e (+ col 2)))
3785 4564 (nthcdr (+ n 1) expr)))
3786 4565 (rpar)
3787 4566 t)
3788 4567
3789 4568 (def ppr-call (expr col noindent)
3790 4569 (lpar)
3791 4570 (let carstr (tostring (write (car expr)))
3792 4571 (pr carstr)
3793 4572 (if (cdr expr)
3794 4573 (do (sp)
3795 4574 (let broke (ppr (cadr expr) (+ col (len carstr) 2) t)
3796 4575 (pprest (cddr expr)
3797 4576 (+ col (len carstr) 2)
3798 4577 (no broke)))
3799 4578 t)
3800 4579 (do (rpar) t))))
3801 4580
3802 4581 (def pprest (exprs col (o oneline t))
3803 4582 (if (and oneline
3804 4583 (all (fn (e)
3805 4584 (or (atom e) (and (is (car e) 'quote) (atom (cadr e)))))
3806 4585 exprs))
3807 4586 (do (map (fn (e) (pr " ") (write e))
3808 4587 exprs)
3809 4588 (rpar))
3810 4589 (do (when exprs
3811 4590 (each e exprs (prn) (ppr e col)))
3812 4591 (rpar))))
3813 4592
3814 4593 (def write-spaced (xs)
3815 4594 (when xs
3816 4595 (write (car xs))
3817 4596 (each x (cdr xs) (pr " ") (write x))))
3818 4597
3819 4598 (def sp ((o n 1)) (repeat n (pr " ")))
3820 4599 (def lpar () (pr "("))
3821 4600 (def rpar () (pr ")"))
3822 4601
3823 4602
================================================================================
prompt.arc
================================================================================
3825 4604 ; Prompt: Web-based programming application. 4 Aug 06.
3826 4605
3827 4606 (= appdir* "arc/apps/")
3828 4607
3829 4608 (defop prompt req
3830 4609 (let user (get-user req)
3831 4610 (if (admin user)
3832 4611 (prompt-page user)
3833 4612 (pr "Sorry."))))
3834 4613
3835 4614 (def prompt-page (user . msg)
3836 4615 (ensure-dir appdir*)
3837 4616 (ensure-dir (string appdir* user))
3838 4617 (whitepage
3839 4618 (prbold "Prompt")
3840 4619 (hspace 20)
3841 4620 (pr user " | ")
3842 4621 (link "logout")
3843 4622 (when msg (hspace 10) (apply pr msg))
3844 4623 (br2)
3845 4624 (tag (table border 0 cellspacing 10)
3846 4625 (each app (dir (+ appdir* user))
3847 4626 (tr (td app)
3848 < (td (userlink user 'edit (edit-app user app)))
3849 < (td (userlink user 'run (run-app user app)))
4627 > (td (ulink user 'edit (edit-app user app)))
4628 > (td (ulink user 'run (run-app user app)))
3850 4629 (td (hspace 40)
3851 < (userlink user 'delete (rem-app user app))))))
4630 > (ulink user 'delete (rem-app user app))))))
3852 4631 (br2)
3853 4632 (aform (fn (req)
3854 < (when-usermatch user req
4633 > (when-umatch user req
3855 4634 (aif (goodname (arg req "app"))
3856 4635 (edit-app user it)
3857 4636 (prompt-page user "Bad name."))))
3858 4637 (tab (row "name:" (input "app") (submit "create app"))))))
3859 4638
3860 4639 (def app-path (user app)
3861 4640 (and user app (+ appdir* user "/" app)))
3862 4641
3863 4642 (def read-app (user app)
3864 4643 (aand (app-path user app)
3865 4644 (file-exists it)
3866 < (w/infile i it (readall i))))
4645 > (readfile it)))
3867 4646
3868 4647 (def write-app (user app exprs)
3869 4648 (awhen (app-path user app)
3870 4649 (w/outfile o it
3871 4650 (each e exprs (write e o)))))
3872 4651
3873 4652 (def rem-app (user app)
3874 4653 (let file (app-path user app)
3875 4654 (if (file-exists file)
3876 4655 (do (rmfile (app-path user app))
3877 4656 (prompt-page user "Program " app " deleted."))
3878 4657 (prompt-page user "No such app."))))
3879 4658
3880 4659 (def edit-app (user app)
3881 4660 (whitepage
3882 4661 (pr "user: " user " app: " app)
3883 4662 (br2)
3884 4663 (aform (fn (req)
3885 4664 (let u2 (get-user req)
3886 4665 (if (is u2 user)
3887 4666 (do (when (is (arg req "cmd") "save")
3888 4667 (write-app user app (readall (arg req "exprs"))))
3889 4668 (prompt-page user))
3890 4669 (login-page 'both nil
3891 4670 (fn (u ip) (prompt-page u))))))
3892 4671 (textarea "exprs" 10 82
3893 4672 (pprcode (read-app user app)))
3894 4673 (br2)
3895 4674 (buts 'cmd "save" "cancel"))))
3896 4675
3897 4676 (def pprcode (exprs)
3898 4677 (each e exprs
3899 4678 (ppr e)
3900 4679 (pr "\n\n")))
3901 4680
3902 4681 (def view-app (user app)
3903 4682 (whitepage
3904 4683 (pr "user: " user " app: " app)
3905 4684 (br2)
3906 4685 (tag xmp (pprcode (read-app user app)))))
3907 4686
3908 4687 (def run-app (user app)
3909 4688 (let exprs (read-app user app)
3910 4689 (if exprs
3911 4690 (on-err (fn (c) (pr "Error: " (details c)))
3912 4691 (fn () (map eval exprs)))
3913 4692 (prompt-page user "Error: No application " app " for user " user))))
3914 4693
3915 < (nil! repl-history*)
4694 > (wipe repl-history*)
3916 4695
3917 4696 (defop repl req
3918 4697 (if (admin (get-user req))
3919 4698 (replpage req)
3920 4699 (pr "Sorry.")))
3921 4700
3922 4701 (def replpage (req)
3923 4702 (whitepage
3924 4703 (repl (readall (or (arg req "expr") "")) "repl")))
3925 4704
3926 4705 (def repl (exprs url)
3927 4706 (each expr exprs
3928 4707 (on-err (fn (c) (push (list expr c t) repl-history*))
3929 4708 (fn ()
3930 4709 (= that (eval expr) thatexpr expr)
3931 4710 (push (list expr that) repl-history*))))
3932 4711 (form url
3933 4712 (textarea "expr" 8 60)
3934 4713 (sp)
3935 4714 (submit))
3936 4715 (tag xmp
3937 4716 (each (expr val err) (firstn 20 repl-history*)
3938 4717 (pr "> ")
3939 4718 (ppr expr)
3940 4719 (prn)
3941 4720 (prn (if err "Error: " "")
3942 4721 (ellipsize (tostring (write val)) 800)))))
3943 4722
3944 4723
================================================================================
srv.arc
================================================================================
3946 < ; (server) then http://tintin.archub.org:8080/foo
3947 <
3948 < ; could make form fields that know their value type because of
3949 < ; gensymed names, and so the receiving fn gets args that are not
3950 < ; strings but parsed values.
3951 <
3952 < ; write w/socket
4725 > ; HTTP Server.
4726 >
4727 > ; To improve performance with static files, set static-max-age*.
4728 >
4729 > (= arcdir* "arc/" logdir* "arc/logs/" staticdir* "static/")
3953 4730
3954 < ; set breaksrv* to t to be able to ^c the server
3955 <
3956 < (= arcdir* "arc/" logdir* "arc/logs/" quitsrv* nil breaksrv* nil)
4731 > (= quitsrv* nil breaksrv* nil)
3957 4732
3958 4733 (def serve ((o port 8080))
3959 < (nil! quitsrv*)
3960 < (ensure-install)
3961 < (let s (open-socket port)
3962 < (prn "ready to serve port " port) ; (flushout)
4734 > (wipe quitsrv*)
4735 > (ensure-srvdirs)
4736 > (map [apply new-bgthread _] pending-bgthreads*)
4737 > (w/socket s port
4738 > (setuid 2) ; XXX switch from root to pg
4739 > (prn "ready to serve port " port)
4740 > (flushout)
3963 4741 (= currsock* s)
3964 < (after (while (no quitsrv*)
3965 < (if breaksrv*
3966 < (handle-request s)
3967 < (errsafe (handle-request s))))
3968 < (close s)
3969 < (prn "quit server"))))
4742 > (until quitsrv*
4743 > (handle-request s breaksrv*)))
4744 > (prn "quit server"))
3970 4745
3971 4746 (def serve1 ((o port 8080))
3972 < (let s (open-socket port)
3973 < (after (handle-request s) (close s))))
4747 > (w/socket s port (handle-request s t)))
4748 >
4749 > (def ensure-srvdirs ()
4750 > (map ensure-dir (list arcdir* logdir* staticdir*)))
3974 4751
3975 4752 (= srv-noisy* nil)
3976 4753
3977 4754 ; http requests currently capped at 2 meg by socket-accept
3978 4755
3979 4756 ; should threads process requests one at a time? no, then
3980 4757 ; a browser that's slow consuming the data could hang the
3981 4758 ; whole server.
3982 4759
3983 4760 ; wait for a connection from a browser and start a thread
3984 4761 ; to handle it. also arrange to kill that thread if it
3985 4762 ; has not completed in threadlife* seconds.
3986 4763
3987 < (= srvthreads* nil threadlimit* 50 threadlife* 30)
3988 <
3989 < ; Could auto-throttle ips, e.g. if one has more than x% of recent requests.
3990 <
3991 < (= requests* 0 requests/ip* (table) throttle-ips* (table) throttle-time* 60)
3992 <
3993 < (def handle-request (s (o life threadlife*))
3994 < (if (< (len (= srvthreads* (rem dead srvthreads*)))
3995 < threadlimit*)
3996 < (with ((i o ip) (socket-accept s))
3997 < (++ requests*)
3998 < (= (requests/ip* ip) (+ 1 (or (requests/ip* ip) 0)))
3999 < (let th (thread (fn ()
4000 < (if (throttle-ips* ip) (sleep (rand throttle-time*)))
4001 < (handle-request-thread i o ip)))
4002 < (push th srvthreads*)
4003 < (thread (fn ()
4004 < (sleep life)
4005 < (unless (dead th) (prn "srv thread took too long"))
4006 < (break-thread th)
4007 < (close o)
4008 < (close i)))))
4009 < (sleep .2)))
4764 > (= threadlife* 30 requests* 0 requests/ip* (table)
4765 > throttle-ips* (table) ignore-ips* (table) spurned* (table))
4766 >
4767 > (def handle-request (s breaksrv)
4768 > (if breaksrv
4769 > (handle-request-1 s)
4770 > (errsafe (handle-request-1 s))))
4771 >
4772 > (def handle-request-1 (s)
4773 > (let (i o ip) (socket-accept s)
4774 > (if (and (or (ignore-ips* ip) (abusive-ip ip))
4775 > (++ (spurned* ip 0)))
4776 > (force-close i o)
4777 > (do (++ requests*)
4778 > (++ (requests/ip* ip 0))
4779 > (with (th1 nil th2 nil)
4780 > (= th1 (thread
4781 > (after (handle-request-thread i o ip)
4782 > (close i o)
4783 > (kill-thread th2))))
4784 > (= th2 (thread
4785 > (sleep threadlife*)
4786 > (unless (dead th1)
4787 > (prn "srv thread took too long for " ip))
4788 > (break-thread th1)
4789 > (force-close i o))))))))
4790 >
4791 > ; Returns true if ip has made req-limit* requests in less than
4792 > ; req-window* seconds. If an ip is throttled, only 1 request is
4793 > ; allowed per req-window* seconds. If an ip makes req-limit*
4794 > ; requests in less than dos-window* seconds, it is a treated as a DoS
4795 > ; attack and put in ignore-ips* (for this server invocation).
4796 >
4797 > ; To adjust this while running, adjust the req-window* time, not
4798 > ; req-limit*, because algorithm doesn't enforce decreases in the latter.
4799 >
4800 > (= req-times* (table) req-limit* 30 req-window* 10 dos-window* 2)
4010 4801
4802 > (def abusive-ip (ip)
4803 > (and (only.> (requests/ip* ip) 250)
4804 > (let now (seconds)
4805 > (do1 (if (req-times* ip)
4806 > (and (>= (qlen (req-times* ip))
4807 > (if (throttle-ips* ip) 1 req-limit*))
4808 > (let dt (- now (deq (req-times* ip)))
4809 > (if (< dt dos-window*) (set (ignore-ips* ip)))
4810 > (< dt req-window*)))
4811 > (do (= (req-times* ip) (queue))
4812 > nil))
4813 > (enq now (req-times* ip))))))
4814 >
4011 4815 (def handle-request-thread (i o ip)
4012 < (with (nls 0 lines nil line nil responded nil)
4816 > (with (nls 0 lines nil line nil responded nil t0 (msec))
4013 4817 (after
4014 < (whilet c (and (no responded) (readc i))
4818 > (whilet c (unless responded (readc i))
4015 4819 (if srv-noisy* (pr c))
4016 4820 (if (is c #\newline)
4017 4821 (if (is (++ nls) 2)
4018 < (do (let (type op args n cooks) (parseheader (rev lines))
4019 < (srvlog 'srv ip type op cooks)
4020 < (case type
4021 < get (respond o op args cooks ip)
4022 < post (handle-post i o op n cooks ip)
4023 < (respond-err o "Unknown request: " (car lines))))
4024 < (= responded t))
4025 < (do (push (coerce (rev line) 'string) lines)
4026 < (= line nil)))
4822 > (let (type op args n cooks) (parseheader (rev lines))
4823 > (let t1 (msec)
4824 > (case type
4825 > get (respond o op args cooks ip)
4826 > post (handle-post i o op args n cooks ip)
4827 > (respond-err o "Unknown request: " (car lines)))
4828 > (log-request type op args cooks ip t0 t1)
4829 > (set responded)))
4830 > (do (push (string (rev line)) lines)
4831 > (wipe line)))
4027 4832 (unless (is c #\return)
4028 4833 (push c line)
4029 4834 (= nls 0))))
4030 < (close o)
4031 < (close i)))
4835 > (close i o)))
4032 4836 (harvest-fnids))
4033 4837
4838 > (def log-request (type op args cooks ip t0 t1)
4839 > (with (parsetime (- t1 t0) respondtime (- (msec) t1))
4840 > (srvlog 'srv ip
4841 > parsetime
4842 > respondtime
4843 > (if (> (+ parsetime respondtime) 1000) "***" "")
4844 > type
4845 > op
4846 > (let arg1 (car args)
4847 > (if (caris arg1 "fnid") "" arg1))
4848 > cooks)))
4849 >
4034 4850 ; Could ignore return chars (which come from textarea fields) here by
4035 4851 ; (unless (is c #\return) (push c line))
4036 4852
4037 < (def handle-post (i o op n cooks ip)
4853 > (def handle-post (i o op args n cooks ip)
4038 4854 (if srv-noisy* (pr "Post Contents: "))
4039 4855 (if (no n)
4040 4856 (respond-err o "Post request without Content-Length.")
4041 4857 (let line nil
4042 4858 (whilet c (and (> n 0) (readc i))
4043 4859 (if srv-noisy* (pr c))
4044 4860 (-- n)
4045 4861 (push c line))
4046 4862 (if srv-noisy* (pr "\n\n"))
4047 < (respond o op (parseargs (coerce (rev line) 'string)) cooks ip))))
4863 > (respond o op (+ (parseargs (string (rev line))) args) cooks ip))))
4048 4864
4049 < (= header* "HTTP/1.0 200 OK
4050 < Content-Type: text/html
4865 > (= header* "HTTP/1.1 200 OK
4866 > Content-Type: text/html; charset=utf-8
4051 4867 Connection: close")
4052 4868
4053 < (= gif-header* "HTTP/1.0 200 OK
4054 < Content-Type: image/gif
4055 < Connection: close")
4869 > (= type-header* (table))
4870 >
4871 > (def gen-type-header (ctype)
4872 > (+ "HTTP/1.0 200 OK
4873 > Content-Type: "
4874 > ctype
4875 > "
4876 > Connection: close"))
4056 4877
4878 > (map (fn ((k v)) (= (type-header* k) (gen-type-header v)))
4879 > '((gif "image/gif")
4880 > (jpg "image/jpeg")
4881 > (png "image/png")
4882 > (text/html "text/html; charset=utf-8")))
4883 >
4057 4884 (= rdheader* "HTTP/1.0 302 Moved")
4058 4885
4059 < (= srvops* (table) redirectors* (table) optimes* (table))
4886 > (= srvops* (table) redirector* (table) optimes* (table) opcounts* (table))
4060 4887
4061 4888 (def save-optime (name elapsed)
4889 > ; this is the place to put a/b testing
4890 > ; toggle a flag and push elapsed into one of two lists
4891 > (++ (opcounts* name 0))
4062 4892 (unless (optimes* name) (= (optimes* name) (queue)))
4063 4893 (enq-limit elapsed (optimes* name) 1000))
4064 4894
4065 4895 ; For ops that want to add their own headers. They must thus remember
4066 4896 ; to prn a blank line before anything meant to be part of the page.
4067 4897
4068 4898 (mac defop-raw (name parms . body)
4069 4899 (w/uniq t1
4070 4900 `(= (srvops* ',name)
4071 4901 (fn ,parms
4072 4902 (let ,t1 (msec)
4073 4903 (do1 (do ,@body)
4074 4904 (save-optime ',name (- (msec) ,t1))))))))
4075 4905
4076 4906 (mac defopr-raw (name parms . body)
4077 < `(= (redirectors* ',name) t
4078 < (srvops* ',name) (fn ,parms ,@body)))
4907 > `(= (redirector* ',name) t
4908 > (srvops* ',name) (fn ,parms ,@body)))
4079 4909
4080 4910 (mac defop (name parm . body)
4081 4911 (w/uniq gs
4082 < `(defop-raw ,name (,gs ,parm)
4083 < (w/stdout ,gs (prn) ,@body))))
4912 > `(do (wipe (redirector* ',name))
4913 > (defop-raw ,name (,gs ,parm)
4914 > (w/stdout ,gs (prn) ,@body)))))
4084 4915
4085 4916 ; Defines op as a redirector. Its retval is new location.
4086 4917
4087 4918 (mac defopr (name parm . body)
4088 4919 (w/uniq gs
4089 < `(do (t! (redirectors* ',name))
4920 > `(do (set (redirector* ',name))
4090 4921 (defop-raw ,name (,gs ,parm)
4091 4922 ,@body))))
4092 4923
4093 4924 ;(mac testop (name . args) `((srvops* ',name) ,@args))
4094 4925
4095 4926 (deftem request
4096 4927 args nil
4097 4928 cooks nil
4098 4929 ip nil)
4099 4930
4100 < (= unknown-msg* "Unknown operator.")
4931 > (= unknown-msg* "Unknown." max-age* (table) static-max-age* nil)
4101 4932
4102 4933 (def respond (str op args cooks ip)
4103 4934 (w/stdout str
4104 < (if (gifname op)
4105 < (do (prn gif-header*)
4106 < (prn)
4107 < (w/infile i (coerce op 'string)
4108 < (whilet b (readb i)
4109 < (writeb b str))))
4110 < (aif (srvops* op)
4111 < (let req (inst 'request 'args args 'cooks cooks 'ip ip)
4112 < (if (redirectors* op)
4113 < (do (prn rdheader*)
4114 < (let loc (it str req) ; may write to str, e.g. cookies
4115 < (prn "Location: " loc))
4116 < (prn))
4117 < (do (prn header*)
4118 < (it str req))))
4119 < (respond-err str unknown-msg*)))))
4935 > (iflet f (srvops* op)
4936 > (let req (inst 'request 'args args 'cooks cooks 'ip ip)
4937 > (if (redirector* op)
4938 > (do (prn rdheader*)
4939 > (prn "Location: " (f str req))
4940 > (prn))
4941 > (do (prn header*)
4942 > (awhen (max-age* op)
4943 > (prn "Cache-Control: max-age=" it))
4944 > (f str req))))
4945 > (let filetype (static-filetype op)
4946 > (aif (and filetype (file-exists (string staticdir* op)))
4947 > (do (prn (type-header* filetype))
4948 > (awhen static-max-age*
4949 > (prn "Cache-Control: max-age=" it))
4950 > (prn)
4951 > (w/infile i it
4952 > (whilet b (readb i)
4953 > (writeb b str))))
4954 > (respond-err str unknown-msg*))))))
4120 4955
4121 < (def gifname (sym)
4122 < (let str (coerce sym 'string)
4123 < (and (endmatch ".gif" str) (~find #\/ str))))
4956 > (def static-filetype (sym)
4957 > (let fname (coerce sym 'string)
4958 > (and (~find #\/ fname)
4959 > (case (downcase (last (check (tokens fname #\.) ~single)))
4960 > "gif" 'gif
4961 > "jpg" 'jpg
4962 > "jpeg" 'jpg
4963 > "png" 'png
4964 > "css" 'text/html
4965 > "txt" 'text/html
4966 > "htm" 'text/html
4967 > "html" 'text/html
4968 > "arc" 'text/html
4969 > ))))
4124 4970
4125 4971 (def respond-err (str msg . args)
4126 4972 (w/stdout str
4127 4973 (prn header*)
4128 4974 (prn)
4129 4975 (apply pr msg args)))
4130 4976
4131 4977 (def parseheader (lines)
4132 4978 (let (type op args) (parseurl (car lines))
4133 4979 (list type
4134 4980 op
4135 4981 args
4136 4982 (and (is type 'post)
4137 4983 (some (fn (s)
4138 4984 (and (begins s "Content-Length:")
4139 < (coerce (cadr (tokens s)) 'int)))
4985 > (errsafe:coerce (cadr (tokens s)) 'int)))
4140 4986 (cdr lines)))
4141 4987 (some (fn (s)
4142 4988 (and (begins s "Cookie:")
4143 4989 (parsecookies s)))
4144 4990 (cdr lines)))))
4145 4991
4146 4992 ; (parseurl "GET /p1?foo=bar&ug etc") -> (get p1 (("foo" "bar") ("ug")))
4147 4993
4148 4994 (def parseurl (s)
4149 4995 (let (type url) (tokens s)
4150 4996 (let (base args) (tokens url #\?)
4151 < (list (coerce (downcase type) 'sym)
4152 < (coerce (subseq base 1) 'sym)
4997 > (list (sym (downcase type))
4998 > (sym (cut base 1))
4153 4999 (if args
4154 5000 (parseargs args)
4155 5001 nil)))))
4156 5002
4157 < ; don't urldecode field names or anything in cookies; correct?
5003 > ; I don't urldecode field names or anything in cookies; correct?
4158 5004
4159 5005 (def parseargs (s)
4160 5006 (map (fn ((k v)) (list k (urldecode v)))
4161 5007 (map [tokens _ #\=] (tokens s #\&))))
4162 5008
4163 5009 (def parsecookies (s)
4164 5010 (map [tokens _ #\=]
4165 5011 (cdr (tokens s [or (whitec _) (is _ #\;)]))))
4166 5012
4167 < (def arg (req key) (alref (req 'args) key))
5013 > (def arg (req key) (alref req!args key))
4168 5014
4169 5015 ; *** Warning: does not currently urlencode args, so if need to do
4170 5016 ; that replace v with (urlencode v).
4171 5017
4172 5018 (def reassemble-args (req)
4173 < (aif (req 'args)
5019 > (aif req!args
4174 5020 (apply string "?" (intersperse '&
4175 < (map (fn (pair)
4176 < (let (k v) pair
4177 < (string k '= v)))
5021 > (map (fn ((k v))
5022 > (string k '= v))
4178 5023 it)))
4179 5024 ""))
4180 5025
4181 5026 (= fns* (table) fnids* nil timed-fnids* nil)
4182 5027
4183 5028 ; count on huge (expt 64 10) size of fnid space to avoid clashes
4184 5029
4185 5030 (def new-fnid ()
4186 < (let key (sym (rand-string 10))
4187 < (if (fns* key)
4188 < (new-fnid)
4189 < key)))
5031 > (check (sym (rand-string 10)) ~fns* (new-fnid)))
4190 5032
4191 5033 (def fnid (f)
4192 5034 (atlet key (new-fnid)
4193 5035 (= (fns* key) f)
4194 5036 (push key fnids*)
4195 5037 key))
4196 5038
4197 5039 (def timed-fnid (lasts f)
4198 5040 (atlet key (new-fnid)
4199 5041 (= (fns* key) f)
4200 5042 (push (list key (seconds) lasts) timed-fnids*)
4201 5043 key))
4202 5044
4203 5045 ; Within f, it will be bound to the fn's own fnid. Remember that this is
4204 5046 ; so low-level that need to generate the newline to separate from the headers
4205 5047 ; within the body of f.
4206 5048
4207 5049 (mac afnid (f)
4208 5050 `(atlet it (new-fnid)
4209 5051 (= (fns* it) ,f)
4210 5052 (push it fnids*)
4211 5053 it))
4212 5054
4213 5055 ;(defop test-afnid req
4214 5056 ; (tag (a href (url-for (afnid (fn (req) (prn) (pr "my fnid is " it)))))
4215 5057 ; (pr "click here")))
4216 5058
4217 5059 ; To be more sophisticated, instead of killing fnids, could first
4218 5060 ; replace them with fns that tell the server it's harvesting too
4219 5061 ; aggressively if they start to get called. But the right thing to
4220 5062 ; do is estimate what the max no of fnids can be and set the harvest
4221 5063 ; limit there-- beyond that the only solution is to buy more memory.
4222 5064
4223 < (def harvest-fnids ((o n 20000))
4224 < (when (> (len fns*) n)
4225 < (atomic
4226 < (pull (fn ((id created lasts))
4227 < (when (> (- (seconds) created) lasts)
4228 < (nil! (fns* id))
4229 < t))
4230 < timed-fnids*))
4231 < (atlet nharvest (truncate (/ n 10))
4232 < (let (kill keep) (splitn nharvest (rev fnids*))
5065 > (def harvest-fnids ((o n 50000)) ; was 20000
5066 > (when (len> fns* n)
5067 > (pull (fn ((id created lasts))
5068 > (when (> (since created) lasts)
5069 > (wipe (fns* id))
5070 > t))
5071 > timed-fnids*)
5072 > (atlet nharvest (trunc (/ n 10))
5073 > (let (kill keep) (split (rev fnids*) nharvest)
4233 5074 (= fnids* (rev keep))
4234 5075 (each id kill
4235 < (nil! (fns* id)))))))
5076 > (wipe (fns* id)))))))
4236 5077
4237 < (= fnurl* "x" rfnurl* "r" rfnurl2* "y" jfnurl* "a")
5078 > (= fnurl* "/x" rfnurl* "/r" rfnurl2* "/y" jfnurl* "/a")
5079 >
5080 > (= dead-msg* "\nUnknown or expired link.")
4238 5081
4239 5082 (defop-raw x (str req)
4240 < (let id (sym (arg req "fnid"))
4241 < (aif (fns* id)
4242 < (w/stdout str (it req))
4243 < (w/stdout str (prn) (pr "unknown or expired link")))))
5083 > (w/stdout str
5084 > (aif (fns* (sym (arg req "fnid")))
5085 > (it req)
5086 > (pr dead-msg*))))
4244 5087
4245 5088 (defopr-raw y (str req)
4246 < (let id (sym (arg req "fnid"))
4247 < (aif (fns* id)
4248 < (w/stdout str (it req))
4249 < "deadlink")))
5089 > (aif (fns* (sym (arg req "fnid")))
5090 > (w/stdout str (it req))
5091 > "deadlink"))
4250 5092
4251 5093 ; For asynchronous calls; discards the page. Would be better to tell
4252 5094 ; the fn not to generate it.
4253 5095
4254 5096 (defop-raw a (str req)
4255 < (let id (sym (arg req "fnid"))
4256 < (aif (fns* id) (tostring (it req)))))
5097 > (aif (fns* (sym (arg req "fnid")))
5098 > (tostring (it req))))
4257 5099
4258 5100 (defopr r req
4259 < (let id (sym (arg req "fnid"))
4260 < (aif (fns* id)
4261 < (it req)
4262 < "deadlink")))
5101 > (aif (fns* (sym (arg req "fnid")))
5102 > (it req)
5103 > "deadlink"))
4263 5104
4264 5105 (defop deadlink req
4265 < (pr "unknown or expired link"))
5106 > (pr dead-msg*))
4266 5107
4267 5108 (def url-for (fnid)
4268 5109 (string fnurl* "?fnid=" fnid))
4269 5110
4270 5111 (def flink (f)
4271 5112 (string fnurl* "?fnid=" (fnid (fn (req) (prn) (f req)))))
4272 5113
4273 < ; couldn't I just say (fnid f) here?
4274 <
4275 5114 (def rflink (f)
4276 < (string rfnurl* "?fnid=" (fnid (fn (req) (f req)))))
5115 > (string rfnurl* "?fnid=" (fnid f)))
4277 5116
4278 5117 ; Since it's just an expr, gensym a parm for (ignored) args.
4279 5118
4280 5119 (mac w/link (expr . body)
4281 < (w/uniq g
4282 < `(tag (a href (flink (fn (,g) ,expr)))
4283 < ,@body)))
5120 > `(tag (a href (flink (fn (,(uniq)) ,expr)))
5121 > ,@body))
4284 5122
4285 5123 (mac w/rlink (expr . body)
4286 < (w/uniq g
4287 < `(tag (a href (rflink (fn (,g) ,expr)))
4288 < ,@body)))
5124 > `(tag (a href (rflink (fn (,(uniq)) ,expr)))
5125 > ,@body))
4289 5126
4290 5127 (mac onlink (text . body)
4291 5128 `(w/link (do ,@body) (pr ,text)))
5129 >
5130 > (mac onrlink (text . body)
5131 > `(w/rlink (do ,@body) (pr ,text)))
4292 5132
4293 5133 ; bad to have both flink and linkf; rename flink something like fnid-link
4294 5134
4295 5135 (mac linkf (text parms . body)
4296 5136 `(tag (a href (flink (fn ,parms ,@body))) (pr ,text)))
4297 5137
4298 5138 (mac rlinkf (text parms . body)
4299 5139 `(tag (a href (rflink (fn ,parms ,@body))) (pr ,text)))
4300 5140
4301 5141 ;(defop top req (linkf 'whoami? (req) (pr "I am " (get-user req))))
4302 5142
4303 5143 ;(defop testf req (w/link (pr "ha ha ha") (pr "laugh")))
4304 5144
4305 5145 (mac w/link-if (test expr . body)
4306 < (w/uniq g
4307 < `(tag-if ,test (a href (flink (fn (,g) ,expr)))
4308 < ,@body)))
5146 > `(tag-if ,test (a href (flink (fn (,(uniq)) ,expr)))
5147 > ,@body))
4309 5148
5149 > (def fnid-field (id)
5150 > (gentag input type 'hidden name 'fnid value id))
5151 >
4310 5152 ; f should be a fn of one arg, which will be http request args.
5153 >
5154 > (def fnform (f bodyfn (o redir))
5155 > (tag (form method 'post action (if redir rfnurl2* fnurl*))
5156 > (fnid-field (fnid f))
5157 > (bodyfn)))
5158 >
4311 5159 ; Could also make a version that uses just an expr, and var capture.
4312 5160 ; Is there a way to ensure user doesn't use "fnid" as a key?
4313 5161
4314 5162 (mac aform (f . body)
4315 < (w/uniq (gi ga)
4316 < `(let ,gi (fnid (fn (,ga)
4317 < (prn)
4318 < (,f ,ga)))
4319 < (tag (form method 'post action fnurl*)
4320 < (gentag input type 'hidden name 'fnid value ,gi)
4321 < ,@body))))
5163 > (w/uniq ga
5164 > `(tag (form method 'post action fnurl*)
5165 > (fnid-field (fnid (fn (,ga)
5166 > (prn)
5167 > (,f ,ga))))
5168 > ,@body)))
4322 5169
5170 > ;(defop test1 req
5171 > ; (fnform (fn (req) (prn) (pr req))
5172 > ; (fn () (single-input "" 'foo 20 "submit"))))
5173 >
5174 > ;(defop test2 req
5175 > ; (aform (fn (req) (pr req))
5176 > ; (single-input "" 'foo 20 "submit")))
5177 >
4323 5178 ; Like aform except creates a fnid that will last for lasts seconds
4324 5179 ; (unless the server is restarted).
4325 5180
4326 < (mac timed-aform (lasts f . body)
5181 > (mac taform (lasts f . body)
4327 5182 (w/uniq (gl gf gi ga)
4328 5183 `(withs (,gl ,lasts
4329 < ,gf (fn (,ga) (prn) (,f ,ga))
4330 < ,gi (if ,gl (timed-fnid ,lasts ,gf) (fnid ,gf)))
5184 > ,gf (fn (,ga) (prn) (,f ,ga)))
4331 5185 (tag (form method 'post action fnurl*)
4332 < (gentag input type 'hidden name 'fnid value ,gi)
5186 > (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
4333 5187 ,@body))))
4334 5188
4335 5189 (mac arform (f . body)
4336 < (w/uniq gi
4337 < `(let ,gi (fnid ,f)
5190 > `(tag (form method 'post action rfnurl*)
5191 > (fnid-field (fnid ,f))
5192 > ,@body))
5193 >
5194 > ; overlong
5195 >
5196 > (mac tarform (lasts f . body)
5197 > (w/uniq (gl gf)
5198 > `(withs (,gl ,lasts ,gf ,f)
4338 5199 (tag (form method 'post action rfnurl*)
4339 < (gentag input type 'hidden name 'fnid value ,gi)
5200 > (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
4340 5201 ,@body))))
4341 5202
4342 5203 (mac aformh (f . body)
4343 < (w/uniq gi
4344 < `(let ,gi (fnid ,f)
4345 < (tag (form method 'post action fnurl*)
4346 < (gentag input type 'hidden name 'fnid value ,gi)
4347 < ,@body))))
5204 > `(tag (form method 'post action fnurl*)
5205 > (fnid-field (fnid ,f))
5206 > ,@body))
4348 5207
4349 5208 (mac arformh (f . body)
4350 < (w/uniq gi
4351 < `(let ,gi (fnid ,f)
4352 < (tag (form method 'post action rfnurl2*)
4353 < (gentag input type 'hidden name 'fnid value ,gi)
4354 < ,@body))))
5209 > `(tag (form method 'post action rfnurl2*)
5210 > (fnid-field (fnid ,f))
5211 > ,@body))
4355 5212
4356 5213 ; only unique per server invocation
4357 5214
4358 5215 (= unique-ids* (table))
4359 5216
4360 5217 (def unique-id ((o len 8))
4361 5218 (let id (sym (rand-string (max 5 len)))
4362 5219 (if (unique-ids* id)
4363 5220 (unique-id)
4364 5221 (= (unique-ids* id) id))))
4365 5222
4366 <
4367 5223 (def srvlog (type . args)
4368 < (w/appendfile o (string logdir* type "-" (memodate))
4369 < (w/stdout o (apply prs (seconds) args) (prn))))
5224 > (w/appendfile o (logfile-name type)
5225 > (w/stdout o (atomic (apply prs (seconds) args) (prn)))))
4370 5226
5227 > (def logfile-name (type)
5228 > (string logdir* type "-" (memodate)))
5229 >
4371 5230 (with (lastasked nil lastval nil)
4372 5231
4373 5232 (def memodate ()
4374 5233 (let now (seconds)
4375 5234 (if (or (no lastasked) (> (- now lastasked) 60))
4376 < (= lastasked now lastval (date))
5235 > (= lastasked now lastval (datestring))
4377 5236 lastval)))
4378 5237
4379 5238 )
4380 5239
4381 < (defop || req
4382 < (pr "It's alive."))
5240 > (defop || req (pr "It's alive."))
4383 5241
4384 5242 (defop topips req
4385 5243 (when (admin (get-user req))
4386 5244 (whitepage
4387 < (spacetable
5245 > (sptab
4388 5246 (each ip (let leaders nil
4389 5247 (maptable (fn (ip n)
4390 5248 (when (> n 100)
4391 5249 (insort (compare > requests/ip*)
4392 5250 ip
4393 5251 leaders)))
4394 5252 requests/ip*)
4395 5253 leaders)
4396 5254 (let n (requests/ip* ip)
4397 < (row ip n (num (* 100 (/ n requests*)) 1))))))))
5255 > (row ip n (pr (num (* 100 (/ n requests*)) 1)))))))))
4398 5256
4399 < (def ensure-install ()
4400 < (ensure-dir arcdir*)
4401 < (ensure-dir logdir*)
4402 < (when (empty hpasswords*)
4403 < (create-acct "frug" "frug")
4404 < (writefile1 'frug adminfile*))
4405 < (load-userinfo))
5257 > (defop spurned req
5258 > (when (admin (get-user req))
5259 > (whitepage
5260 > (sptab
5261 > (map (fn ((ip n)) (row ip n))
5262 > (sortable spurned*))))))
5263 >
5264 > ; eventually promote to general util
5265 >
5266 > (def sortable (ht (o f >))
5267 > (let res nil
5268 > (maptable (fn kv
5269 > (insort (compare f cadr) kv res))
5270 > ht)
5271 > res))
5272 >
5273 >
5274 > ; Background Threads
5275 >
5276 > (= bgthreads* (table) pending-bgthreads* nil)
5277 >
5278 > (def new-bgthread (id f sec)
5279 > (aif (bgthreads* id) (break-thread it))
5280 > (= (bgthreads* id) (new-thread (fn ()
5281 > (while t
5282 > (sleep sec)
5283 > (f))))))
4406 5284
5285 > ; should be a macro for this?
5286 >
5287 > (mac defbg (id sec . body)
5288 > `(do (pull [caris _ ',id] pending-bgthreads*)
5289 > (push (list ',id (fn () ,@body) ,sec)
5290 > pending-bgthreads*)))
5291 >
5292 >
5293 >
5294 > ; Idea: make form fields that know their value type because of
5295 > ; gensymed names, and so the receiving fn gets args that are not
5296 > ; strings but parsed values.
4407 5297
4408 5298
================================================================================
strings.arc
================================================================================
4410 5300 ; Matching. Spun off 29 Jul 06.
4411 5301
4412 < ; Arc> (tostring (writec (coerce 133 'char)))
5302 > ; arc> (tostring (writec (coerce 133 'char)))
4413 5303 ;
4414 5304 ;> (define ss (open-output-string))
4415 5305 ;> (write-char (integer->char 133) ss)
4416 5306 ;> (get-output-string ss)
4417 5307 ;"\u0085"
4418 5308
4419 5309 (def tokens (s (o sep whitec))
4420 < (let test (if (isa sep 'fn) sep (fn (c) (is c sep)))
5310 > (let test (testify sep)
4421 5311 (let rec (afn (cs toks tok)
4422 5312 (if (no cs) (consif tok toks)
4423 5313 (test (car cs)) (self (cdr cs) (consif tok toks) nil)
4424 5314 (self (cdr cs) toks (cons (car cs) tok))))
4425 < (rev (map [coerce _ 'string]
4426 < (map rev (rec (coerce s 'cons) nil nil)))))))
5315 > (rev (map [coerce _ 'string]
5316 > (map rev (rec (coerce s 'cons) nil nil)))))))
4427 5317
5318 > ; names of cut, split, halve not optimal
5319 >
5320 > (def halve (s (o sep whitec))
5321 > (let test (testify sep)
5322 > (let rec (afn (cs tok)
5323 > (if (no cs) (list (rev tok))
5324 > (test (car cs)) (list cs (rev tok))
5325 > (self (cdr cs) (cons (car cs) tok))))
5326 > (rev (map [coerce _ 'string]
5327 > (rec (coerce s 'cons) nil))))))
5328 >
5329 > ; maybe promote to arc.arc, but if so include a list clause
5330 >
5331 > (def positions (test seq)
5332 > (accum a
5333 > (let f (testify test)
5334 > (forlen i seq
5335 > (if (f (seq i)) (a i))))))
5336 >
5337 > (def lines (s)
5338 > (accum a
5339 > ((afn ((p . ps))
5340 > (if ps
5341 > (do (a (rem #\return (cut s (+ p 1) (car ps))))
5342 > (self ps))
5343 > (a (cut s (+ p 1)))))
5344 > (cons -1 (positions #\newline s)))))
5345 >
5346 > (def slices (s test)
5347 > (accum a
5348 > ((afn ((p . ps))
5349 > (if ps
5350 > (do (a (cut s (+ p 1) (car ps)))
5351 > (self ps))
5352 > (a (cut s (+ p 1)))))
5353 > (cons -1 (positions test s)))))
5354 >
4428 5355 ; > (require (lib "uri-codec.ss" "net"))
4429 5356 ;> (form-urlencoded-decode "x%ce%bbx")
4430 5357 ;"xλx"
4431 5358
4432 5359 ; first byte: 0-7F, 1 char; c2-df 2; e0-ef 3, f0-f4 4.
4433 5360
5361 > ; Fixed for utf8 by pc.
5362 >
4434 5363 (def urldecode (s)
4435 < (tostring
4436 < (forlen i s
4437 < (caselet c (s i)
4438 < #\+ (writec #\space)
4439 < #\% (do (when (> (- (len s) i) 2)
4440 < (let code (coerce (subseq s (+ i 1) (+ i 3))
4441 < 'int 16)
4442 < (if (> code 126)
4443 < (pr (latin1-hack code))
4444 < (writec (coerce code 'char)))))
4445 < (++ i 2))
4446 < (writec c)))))
5364 > (tostring
5365 > (forlen i s
5366 > (caselet c (s i)
5367 > #\+ (writec #\space)
5368 > #\% (do (when (> (- (len s) i) 2)
5369 > (writeb (int (cut s (+ i 1) (+ i 3)) 16)))
5370 > (++ i 2))
5371 > (writec c)))))
4447 5372
4448 <
4449 < ; Converts utf8 chars between 128 and 255 to ascii char or string.
4450 < ; Not able to convert every char; generates X if can't. Probably not
4451 < ; the ultimate solution. The Right Thing would be to preserve these
4452 < ; chars, instead of downgrading them to ascii. To do that, would have
4453 < ; to convert them to unicode. E.g. ellipsis in unicode is #x2026,
4454 < ; euro sign is #x20ac.
4455 <
4456 < ; In Mzscheme: (display (integer->char #xE9))
4457 <
4458 < ; Then have to figure out how to print them back out, both in forms
4459 < ; and in pages. Presumably do the reverse translation and &-escape them.
4460 <
4461 < ; For much of this range, unicode and utf8 agree. 233 is e-acute in
4462 < ; both. It's chars like 133 that are a problem. So perhaps as a
4463 < ; start try preserving e.g. 233.
4464 <
4465 < ; This would be faster if I made a macro that translated it into
4466 < ; a hashtable or even string.
4467 <
4468 < (def latin1-hack (i)
4469 < (if (is i 128) "EUR" ; euros
4470 < (is i 133) "..."
4471 < (<= 145 i 146) #\'
4472 < (<= 147 i 148) #\"
4473 < (is i 151) "--" ; long dash
4474 < (is i 154) #\S
4475 < (is i 155) #\>
4476 < (is i 156) "oe"
4477 < (is i 158) #\z
4478 < (is i 159) #\Y
4479 < (is i 162) #\c ; cents
4480 < (is i 163) "GBP" ; pounds
4481 < (is i 165) "JPY" ; yen
4482 < (is i 166) #\|
4483 < (is i 171) "<<"
4484 < (is i 187) ">>"
4485 < (<= 192 i 197) #\A
4486 < (is i 198) "AE"
4487 < (is i 199) #\C
4488 < (<= 200 i 203) #\E
4489 < (<= 204 i 207) #\I
4490 < (is i 209) #\N
4491 < (<= 210 i 214) #\O
4492 < (is i 215) #\x
4493 < (is i 216) #\O
4494 < (<= 217 i 220) #\U
4495 < (is i 221) #\Y
4496 < (is i 223) "ss"
4497 < (<= 224 i 229) #\a
4498 < (is i 230) "ae"
4499 < (is i 231) #\c
4500 < (<= 232 i 235) #\e
4501 < (<= 236 i 239) #\i
4502 < (is i 241) #\n
4503 < (<= 242 i 246) #\o
4504 < (is i 247) #\/
4505 < (is i 248) #\o
4506 < (<= 249 i 252) #\u
4507 < (in i 253 255) #\y
4508 < #\X
4509 < ))
5373 > (def urlencode (s)
5374 > (tostring
5375 > (each c s
5376 > (writec #\%)
5377 > (let i (int c)
5378 > (if (< i 16) (writec #\0))
5379 > (pr (coerce i 'string 16))))))
4510 5380
4511 5381 (mac litmatch (pat string (o start 0))
4512 5382 (w/uniq (gstring gstart)
4513 5383 `(with (,gstring ,string ,gstart ,start)
4514 5384 (unless (> (+ ,gstart ,(len pat)) (len ,gstring))
4515 5385 (and ,@(let acc nil
4516 5386 (forlen i pat
4517 5387 (push `(is ,(pat i) (,gstring (+ ,gstart ,i)))
4518 5388 acc))
4519 5389 (rev acc)))))))
4520 5390
4521 5391 ; litmatch would be cleaner if map worked for string and integer args:
4522 5392
4523 5393 ; ,@(map (fn (n c)
4524 5394 ; `(is ,c (,gstring (+ ,gstart ,n))))
4525 5395 ; (len pat)
4526 5396 ; pat)
4527 5397
4528 5398 (mac endmatch (pat string)
4529 5399 (w/uniq (gstring glen)
4530 5400 `(withs (,gstring ,string ,glen (len ,gstring))
4531 5401 (unless (> ,(len pat) (len ,gstring))
4532 5402 (and ,@(let acc nil
4533 5403 (forlen i pat
4534 5404 (push `(is ,(pat (- (len pat) 1 i))
4535 5405 (,gstring (- ,glen 1 ,i)))
4536 5406 acc))
4537 5407 (rev acc)))))))
4538 5408
4539 5409 (def posmatch (pat seq (o start 0))
4540 5410 (catch
4541 5411 (if (isa pat 'fn)
4542 5412 (for i start (- (len seq) 1)
4543 5413 (when (pat (seq i)) (throw i)))
4544 < (for i start (- (len seq) (- (len pat) 2))
5414 > (for i start (- (len seq) (len pat))
4545 5415 (when (headmatch pat seq i) (throw i))))
4546 5416 nil))
4547 5417
4548 5418 (def headmatch (pat seq (o start 0))
4549 5419 (let p (len pat)
4550 5420 ((afn (i)
4551 5421 (or (is i p)
4552 5422 (and (is (pat i) (seq (+ i start)))
4553 5423 (self (+ i 1)))))
4554 5424 0)))
4555 5425
4556 5426 (def begins (seq pat (o start 0))
4557 < (unless (> (len pat) (- (len seq) start))
5427 > (unless (len> pat (- (len seq) start))
4558 5428 (headmatch pat seq start)))
4559 5429
4560 5430 (def subst (new old seq)
4561 5431 (let boundary (+ (- (len seq) (len old)) 1)
4562 5432 (tostring
4563 5433 (forlen i seq
4564 5434 (if (and (< i boundary) (headmatch old seq i))
4565 5435 (do (++ i (- (len old) 1))
4566 5436 (pr new))
4567 5437 (pr (seq i)))))))
4568 5438
4569 5439 (def multisubst (pairs seq)
4570 5440 (tostring
4571 5441 (forlen i seq
4572 5442 (iflet (old new) (find [begins seq (car _) i] pairs)
4573 5443 (do (++ i (- (len old) 1))
4574 5444 (pr new))
4575 5445 (pr (seq i))))))
4576 5446
5447 > ; not a good name
5448 >
4577 5449 (def findsubseq (pat seq (o start 0))
4578 5450 (if (< (- (len seq) start) (len pat))
4579 5451 nil
4580 5452 (if (headmatch pat seq start)
4581 5453 start
4582 5454 (findsubseq pat seq (+ start 1)))))
4583 5455
4584 5456 (def blank (s) (~find ~whitec s))
4585 5457
4586 < ; should make it possible for test to be a literal as well
4587 <
4588 < (def trim (s where (o test whitec))
4589 < (let p1 (pos [no (test _)] s)
5458 > (def nonblank (s) (unless (blank s) s))
5459 >
5460 > (def trim (s (o where 'both) (o test whitec))
5461 > (withs (f (testify test)
5462 > p1 (pos ~f s))
4590 5463 (if p1
4591 < (subseq s
4592 < (if (in where 'front 'both) p1 0)
4593 < (when (in where 'end 'both)
4594 < (let i (- (len s) 1)
4595 < (while (and (> i p1) (test (s i)))
4596 < (-- i))
4597 < (+ i 1))))
5464 > (cut s
5465 > (if (in where 'front 'both) p1 0)
5466 > (when (in where 'end 'both)
5467 > (let i (- (len s) 1)
5468 > (while (and (> i p1) (f (s i)))
5469 > (-- i))
5470 > (+ i 1))))
4598 5471 "")))
4599 5472
4600 < (def num (m (o digits 2) (o trail-zeros nil) (o init-zero nil))
4601 < (let comma
4602 < (fn (n)
4603 < (tostring
4604 < (map [apply pr (rev _)]
4605 < (rev (intersperse '(#\,)
4606 < (tuples (rev (coerce (string n) 'cons))
4607 < 3))))))
4608 < (if (< digits 1)
4609 < (comma (roundup m))
4610 < (exact m)
4611 < (string (comma m)
4612 < (when (and trail-zeros (> digits 0))
4613 < (string "." (newstring digits #\0))))
4614 < (let n (truncate m)
4615 < (string (if (is n 0) (if init-zero 0 "") (comma n))
4616 < "."
4617 < (withs (rest (string (abs (roundup
4618 < (- (* m (expt 10 digits))
4619 < (* n (expt 10 digits))))))
4620 < v2 (string (newstring (- digits (len rest)) #\0)
4621 < rest))
4622 < (if trail-zeros
4623 < v2
4624 < (trim v2 'end [is _ #\0]))))))))
5473 > (def num (n (o digits 2) (o trail-zeros nil) (o init-zero nil))
5474 > (withs (comma
5475 > (fn (i)
5476 > (tostring
5477 > (map [apply pr (rev _)]
5478 > (rev (intersperse '(#\,)
5479 > (tuples (rev (coerce (string i) 'cons))
5480 > 3))))))
5481 > abrep
5482 > (let a (abs n)
5483 > (if (< digits 1)
5484 > (comma (roundup a))
5485 > (exact a)
5486 > (string (comma a)
5487 > (when (and trail-zeros (> digits 0))
5488 > (string "." (newstring digits #\0))))
5489 > (withs (d (expt 10 digits)
5490 > m (/ (roundup (* a d)) d)
5491 > i (trunc m)
5492 > r (abs (trunc (- (* m d) (* i d)))))
5493 > (+ (if (is i 0)
5494 > (if (or init-zero (is r 0)) "0" "")
5495 > (comma i))
5496 > (withs (rest (string r)
5497 > padded (+ (newstring (- digits (len rest)) #\0)
5498 > rest)
5499 > final (if trail-zeros
5500 > padded
5501 > (trim padded 'end [is _ #\0])))
5502 > (string (unless (empty final) ".")
5503 > final)))))))
5504 > (if (and (< n 0) (find [and (digit _) (isnt _ #\0)] abrep))
5505 > (+ "-" abrep)
5506 > abrep)))
5507 >
5508 >
5509 > ; English
5510 >
5511 > (def pluralize (n str)
5512 > (if (or (is n 1) (single n))
5513 > str
5514 > (string str "s")))
4625 5515
5516 > (def plural (n x)
5517 > (string n #\ (pluralize n x)))
4626 5518
5519 >
4627 5520 ; http://www.eki.ee/letter/chardata.cgi?HTML4=1
4628 5521 ; http://jrgraphix.net/research/unicode_blocks.php?block=1
4629 5522 ; http://home.tiscali.nl/t876506/utf8tbl.html
4630 5523 ; http://www.fileformat.info/info/unicode/block/latin_supplement/utf8test.htm
4631 5524 ; http://en.wikipedia.org/wiki/Utf-8
4632 5525 ; http://unicode.org/charts/charindex2.html
4633 5526
================================================================================
news.arc
================================================================================
5528 > ; News. 2 Sep 06.
5529 >
5530 > ; to run news: (nsv), then go to http://localhost:8080
5531 > ; put usernames of admins, separated by whitespace, in arc/admins
5532 >
5533 > ; bug: somehow (+ votedir* nil) is getting evaluated.
5534 >
5535 > (declare 'atstrings t)
5536 >
5537 > (= this-site* "My Forum"
5538 > site-url* "http://news.yourdomain.com/"
5539 > parent-url* "http://www.yourdomain.com"
5540 > favicon-url* ""
5541 > site-desc* "What this site is about." ; for rss feed
5542 > site-color* (color 180 180 180)
5543 > border-color* (color 180 180 180)
5544 > prefer-url* t)
5545 >
5546 >
5547 > ; Structures
5548 >
5549 > ; Could add (html) types like choice, yesno to profile fields. But not
5550 > ; as part of deftem, which is defstruct. Need another mac on top of
5551 > ; deftem. Should not need the type specs in user-fields.
5552 >
5553 > (deftem profile
5554 > id nil
5555 > name nil
5556 > created (seconds)
5557 > auth 0
5558 > member nil
5559 > submitted nil
5560 > votes nil ; for now just recent, elts each (time id by sitename dir)
5561 > karma 1
5562 > avg nil
5563 > weight .5
5564 > ignore nil
5565 > email nil
5566 > about nil
5567 > showdead nil
5568 > noprocrast nil
5569 > firstview nil
5570 > lastview nil
5571 > maxvisit 20
5572 > minaway 180
5573 > topcolor nil
5574 > keys nil
5575 > delay 0)
5576 >
5577 > (deftem item
5578 > id nil
5579 > type nil
5580 > by nil
5581 > ip nil
5582 > time (seconds)
5583 > url nil
5584 > title nil
5585 > text nil
5586 > votes nil ; elts each (time ip user type score)
5587 > score 0
5588 > sockvotes 0
5589 > flags nil
5590 > dead nil
5591 > deleted nil
5592 > parts nil
5593 > parent nil
5594 > kids nil
5595 > keys nil)
5596 >
5597 >
5598 > ; Load and Save
5599 >
5600 > (= newsdir* "arc/news/"
5601 > storydir* "arc/news/story/"
5602 > profdir* "arc/news/profile/"
5603 > votedir* "arc/news/vote/")
5604 >
5605 > (= votes* (table) profs* (table))
5606 >
5607 > (= initload-users* nil)
5608 >
5609 > (def nsv ((o port 8080))
5610 > (map ensure-dir (list arcdir* newsdir* storydir* votedir* profdir*))
5611 > (unless stories* (load-items))
5612 > (if (and initload-users* (empty profs*)) (load-users))
5613 > (asv port))
5614 >
5615 > (def load-users ()
5616 > (pr "load users: ")
5617 > (noisy-each 100 id (dir profdir*)
5618 > (load-user id)))
5619 >
5620 > ; For some reason vote files occasionally get written out in a
5621 > ; broken way. The nature of the errors (random missing or extra
5622 > ; chars) suggests the bug is lower-level than anything in Arc.
5623 > ; Which unfortunately means all lists written to disk are probably
5624 > ; vulnerable to it, since that's all save-table does.
5625 >
5626 > (def load-user (u)
5627 > (= (votes* u) (load-table (+ votedir* u))
5628 > (profs* u) (temload 'profile (+ profdir* u)))
5629 > u)
5630 >
5631 > ; Have to check goodname because some user ids come from http requests.
5632 > ; So this is like safe-item. Don't need a sep fn there though.
5633 >
5634 > (def profile (u)
5635 > (or (profs* u)
5636 > (aand (goodname u)
5637 > (file-exists (+ profdir* u))
5638 > (= (profs* u) (temload 'profile it)))))
5639 >
5640 > (def votes (u)
5641 > (or (votes* u)
5642 > (aand (file-exists (+ votedir* u))
5643 > (= (votes* u) (load-table it)))))
5644 >
5645 > (def init-user (u)
5646 > (= (votes* u) (table)
5647 > (profs* u) (inst 'profile 'id u))
5648 > (save-votes u)
5649 > (save-prof u)
5650 > u)
5651 >
5652 > ; Need this because can create users on the server (for other apps)
5653 > ; without setting up places to store their state as news users.
5654 > ; See the admin op in app.arc. So all calls to login-page from the
5655 > ; news app need to call this in the after-login fn.
5656 >
5657 > (def ensure-news-user (u)
5658 > (if (profile u) u (init-user u)))
5659 >
5660 > (def save-votes (u) (save-table (votes* u) (+ votedir* u)))
5661 >
5662 > (def save-prof (u) (save-table (profs* u) (+ profdir* u)))
5663 >
5664 > (mac uvar (u k) `((profile ,u) ',k))
5665 >
5666 > (mac karma (u) `(uvar ,u karma))
5667 > (mac ignored (u) `(uvar ,u ignore))
5668 >
5669 > ; Note that users will now only consider currently loaded users.
5670 >
5671 > (def users ((o f idfn))
5672 > (keep f (keys profs*)))
5673 >
5674 > (def check-key (u k)
5675 > (and u (mem k (uvar u keys))))
5676 >
5677 > (def author (u i) (is u i!by))
5678 >
5679 >
5680 > (= stories* nil comments* nil
5681 > items* (table) url->story* (table)
5682 > maxid* 0 initload* 15000)
5683 >
5684 > ; The dir expression yields stories in order of file creation time
5685 > ; (because arc infile truncates), so could just rev the list instead of
5686 > ; sorting, but sort anyway.
5687 >
5688 > ; Note that stories* etc only include the initloaded (i.e. recent)
5689 > ; ones, plus those created since this server process started.
5690 >
5691 > ; Could be smarter about preloading by keeping track of popular pages.
5692 >
5693 > (def load-items ()
5694 > (system (+ "rm " storydir* "*.tmp"))
5695 > (pr "load items: ")
5696 > (with (items (table)
5697 > ids (sort > (map int (dir storydir*))))
5698 > (if ids (= maxid* (car ids)))
5699 > (noisy-each 100 id (firstn initload* ids)
5700 > (let i (load-item id)
5701 > (push i (items i!type))))
5702 > (= stories* (rev (merge (compare < !id) items!story items!poll))
5703 > comments* (rev items!comment))
5704 > (hook 'initload items))
5705 > (ensure-topstories))
5706 >
5707 > (def ensure-topstories ()
5708 > (aif (errsafe (readfile1 (+ newsdir* "topstories")))
5709 > (= ranked-stories* (map item it))
5710 > (do (prn "ranking stories.")
5711 > (flushout)
5712 > (gen-topstories))))
5713 >
5714 > (def astory (i) (is i!type 'story))
5715 > (def acomment (i) (is i!type 'comment))
5716 > (def apoll (i) (is i!type 'poll))
5717 >
5718 > (def load-item (id)
5719 > (let i (temload 'item (+ storydir* id))
5720 > (= (items* id) i)
5721 > (awhen (and (astory&live i) (check i!url ~blank))
5722 > (register-url i it))
5723 > i))
5724 >
5725 > ; Note that duplicates are only prevented of items that have at some
5726 > ; point been loaded.
5727 >
5728 > (def register-url (i url)
5729 > (= (url->story* (canonical-url url)) i!id))
5730 >
5731 > ; redefined later
5732 >
5733 > (= stemmable-sites* (table))
5734 >
5735 > (def canonical-url (url)
5736 > (if (stemmable-sites* (sitename url))
5737 > (cut url 0 (pos #\? url))
5738 > url))
5739 >
5740 > (def new-item-id ()
5741 > (evtil (++ maxid*) [~file-exists (+ storydir* _)]))
5742 >
5743 > (def item (id)
5744 > (or (items* id) (errsafe:load-item id)))
5745 >
5746 > (def kids (i) (map item i!kids))
5747 >
5748 > ; For use on external item references (from urls). Checks id is int
5749 > ; because people try e.g. item?id=363/blank.php
5750 >
5751 > (def safe-item (id)
5752 > (ok-id&item (if (isa id 'string) (saferead id) id)))
5753 >
5754 > (def ok-id (id)
5755 > (and (exact id) (<= 1 id maxid*)))
5756 >
5757 > (def arg->item (req key)
5758 > (safe-item:saferead (arg req key)))
5759 >
5760 > (def live (i) (nor i!dead i!deleted))
5761 >
5762 > (def save-item (i) (save-table i (+ storydir* i!id)))
5763 >
5764 > (def kill (i how)
5765 > (unless i!dead
5766 > (log-kill i how)
5767 > (wipe (comment-cache* i!id))
5768 > (set i!dead)
5769 > (save-item i)))
5770 >
5771 > (= kill-log* nil)
5772 >
5773 > (def log-kill (i how)
5774 > (push (list i!id how) kill-log*))
5775 >
5776 > (mac each-loaded-item (var . body)
5777 > (w/uniq g
5778 > `(let ,g nil
5779 > (loop (= ,g maxid*) (> ,g 0) (-- ,g)
5780 > (whenlet ,var (items* ,g)
5781 > ,@body)))))
5782 >
5783 > (def loaded-items (test)
5784 > (accum a (each-loaded-item i (test&a i))))
5785 >
5786 > (def newslog args (apply srvlog 'news args))
5787 >
5788 >
5789 > ; Ranking
5790 >
5791 > ; Votes divided by the age in hours to the gravityth power.
5792 > ; Would be interesting to scale gravity in a slider.
5793 >
5794 > (= gravity* 1.8 timebase* 120 front-threshold* 1
5795 > nourl-factor* .4 lightweight-factor* .3 )
5796 >
5797 > (def frontpage-rank (s (o scorefn realscore) (o gravity gravity*))
5798 > (* (/ (let base (- (scorefn s) 1)
5799 > (if (> base 0) (expt base .8) base))
5800 > (expt (/ (+ (item-age s) timebase*) 60) gravity))
5801 > (if (no (in s!type 'story 'poll)) .5
5802 > (blank s!url) nourl-factor*
5803 > (lightweight s) (min lightweight-factor*
5804 > (contro-factor s))
5805 > (contro-factor s))))
5806 >
5807 > (def contro-factor (s)
5808 > (aif (check (visible-family nil s) [> _ 20])
5809 > (min 1 (expt (/ (realscore s) it) 2))
5810 > 1))
5811 >
5812 > (def realscore (i) (- i!score i!sockvotes))
5813 >
5814 > (disktable lightweights* (+ newsdir* "lightweights"))
5815 >
5816 > (def lightweight (s)
5817 > (or s!dead
5818 > (mem 'rally s!keys) ; title is a rallying cry
5819 > (mem 'image s!keys) ; post is mainly image(s)
5820 > (lightweights* (sitename s!url))
5821 > (lightweight-url s!url)))
5822 >
5823 > (defmemo lightweight-url (url)
5824 > (in (downcase (last (tokens url #\.))) "png" "jpg" "jpeg"))
5825 >
5826 > (def item-age (i) (minutes-since i!time))
5827 >
5828 > (def user-age (u) (minutes-since (uvar u created)))
5829 >
5830 > ; Only looks at the 1000 most recent stories, which might one day be a
5831 > ; problem if there is massive spam.
5832 >
5833 > (def gen-topstories ()
5834 > (= ranked-stories* (rank-stories 180 1000 (memo frontpage-rank))))
5835 >
5836 > (def save-topstories ()
5837 > (writefile (map !id (firstn 180 ranked-stories*))
5838 > (+ newsdir* "topstories")))
5839 >
5840 > (def rank-stories (n consider scorefn)
5841 > (bestn n (compare > scorefn) (latest-items metastory nil consider)))
5842 >
5843 > ; With virtual lists the above call to latest-items could be simply:
5844 > ; (map item (retrieve consider metastory:item (gen maxid* [- _ 1])))
5845 >
5846 > (def latest-items (test (o stop) (o n))
5847 > (accum a
5848 > (catch
5849 > (down id maxid* 1
5850 > (let i (item id)
5851 > (if (or (and stop (stop i)) (and n (<= n 0)))
5852 > (throw))
5853 > (when (test i)
5854 > (a i)
5855 > (if n (-- n))))))))
5856 >
5857 > ; redefined later
5858 >
5859 > (def metastory (i) (and i (in i!type 'story 'poll)))
5860 >
5861 > (def adjust-rank (s (o scorefn frontpage-rank))
5862 > (insortnew (compare > (memo scorefn)) s ranked-stories*)
5863 > (save-topstories))
5864 >
5865 > ; If something rose high then stopped getting votes, its score would
5866 > ; decline but it would stay near the top. Newly inserted stories would
5867 > ; thus get stuck in front of it. I avoid this by regularly adjusting
5868 > ; the rank of a random top story.
5869 >
5870 > (defbg rerank-random 30 (rerank-random))
5871 >
5872 > (def rerank-random ()
5873 > (when ranked-stories*
5874 > (adjust-rank (ranked-stories* (rand (min 50 (len ranked-stories*)))))))
5875 >
5876 > (def topstories (user n (o threshold front-threshold*))
5877 > (retrieve n
5878 > [and (>= (realscore _) threshold) (cansee user _)]
5879 > ranked-stories*))
5880 >
5881 > (= max-delay* 10)
5882 >
5883 > (def cansee (user i)
5884 > (if i!deleted (admin user)
5885 > i!dead (or (author user i) (seesdead user))
5886 > (delayed i) (author user i)
5887 > t))
5888 >
5889 > (let mature (table)
5890 > (def delayed (i)
5891 > (and (no (mature i!id))
5892 > (acomment i)
5893 > (or (< (item-age i) (min max-delay* (uvar i!by delay)))
5894 > (do (set (mature i!id))
5895 > nil)))))
5896 >
5897 > (def seesdead (user)
5898 > (or (and user (uvar user showdead) (no (ignored user)))
5899 > (editor user)))
5900 >
5901 > (def visible (user is)
5902 > (keep [cansee user _] is))
5903 >
5904 > (def cansee-descendant (user c)
5905 > (or (cansee user c)
5906 > (some [cansee-descendant user (item _)]
5907 > c!kids)))
5908 >
5909 > (def editor (u)
5910 > (and u (or (admin u) (> (uvar u auth) 0))))
5911 >
5912 > (def member (u)
5913 > (and u (or (admin u) (uvar u member))))
5914 >
5915 >
5916 > ; Page Layout
5917 >
5918 > (= up-url* "grayarrow.gif" down-url* "graydown.gif" logo-url* "arc.png")
5919 >
5920 > (defopr favicon.ico req favicon-url*)
5921 >
5922 > ; redefined later
5923 >
5924 > (def gen-css-url ()
5925 > (prn "
. Then whatever
6049 > ; I set the bottom spacing to, it would be the same no matter how many paras
6050 > ; in a comment. In this case by setting the bottom spacing of p to 0, I'm
6051 > ; making it the same as no p, which is what the first para has.
6052 >
6053 > ; supplied by pb
6054 > ;.vote { padding-left:2px; vertical-align:top; }
6055 > ;.comment { margin-top:1ex; margin-bottom:1ex; color:black; }
6056 > ;.vote IMG { border:0; margin: 3px 2px 3px 2px; }
6057 > ;.reply { font-size:smaller; text-decoration:underline !important; }
6058 >
6059 > (= votejs* "
6060 > function byId(id) {
6061 > return document.getElementById(id);
6062 > }
6063 >
6064 > function vote(node) {
6065 > var v = node.id.split(/_/); // {'up', '123'}
6066 > var item = v[1];
6067 >
6068 > // adjust score
6069 > var score = byId('score_' + item);
6070 > var newscore = parseInt(score.innerHTML) + (v[0] == 'up' ? 1 : -1);
6071 > score.innerHTML = newscore + (newscore == 1 ? ' point' : ' points');
6072 >
6073 > // hide arrows
6074 > byId('up_' + item).style.visibility = 'hidden';
6075 > byId('down_' + item).style.visibility = 'hidden';
6076 >
6077 > // ping server
6078 > var ping = new Image();
6079 > ping.src = node.href;
6080 >
6081 > return false; // cancel browser nav
6082 > } ")
6083 >
6084 >
6085 > ; Page top
6086 >
6087 > (= sand (color 246 246 239) textgray (gray 130))
6088 >
6089 > (def main-color (user)
6090 > (aif (and user (uvar user topcolor))
6091 > (hex>color it)
6092 > site-color*))
6093 >
6094 > (def pagetop (switch lid label (o title) (o user) (o whence))
6095 > ; (tr (tdcolor black (vspace 5)))
6096 > (tr (tdcolor (main-color user)
6097 > (tag (table border 0 cellpadding 0 cellspacing 0 width "100%"
6098 > style "padding:2px")
6099 > (tr (gen-logo)
6100 > (when (is switch 'full)
6101 > (tag (td style "line-height:12pt; height:10px;")
6102 > (spanclass pagetop
6103 > (tag b (link this-site* "news"))
6104 > (hspace 10)
6105 > (toprow user label))))
6106 > (if (is switch 'full)
6107 > (tag (td style "text-align:right;padding-right:4px;")
6108 > (spanclass pagetop (topright user whence)))
6109 > (tag (td style "line-height:12pt; height:10px;")
6110 > (spanclass pagetop (prbold label))))))))
6111 > (map [_ user] pagefns*)
6112 > (spacerow 10))
6113 >
6114 > (def gen-logo ()
6115 > (tag (td style "width:18px;padding-right:4px")
6116 > (tag (a href parent-url*)
6117 > (tag (img src logo-url* width 18 height 18
6118 > style "border:1px #@(hexrep border-color*) solid;")))))
6119 >
6120 > (= toplabels* '(nil "welcome" "new" "threads" "comments" "leaders" "*"))
6121 >
6122 > ; redefined later
6123 >
6124 > (= welcome-url* "welcome")
6125 >
6126 > (def toprow (user label)
6127 > (w/bars
6128 > (when (noob user)
6129 > (toplink "welcome" welcome-url* label))
6130 > (toplink "new" "newest" label)
6131 > (when user
6132 > (toplink "threads" (threads-url user) label))
6133 > (toplink "comments" "newcomments" label)
6134 > (toplink "leaders" "leaders" label)
6135 > (hook 'toprow user label)
6136 > (link "submit")
6137 > (unless (mem label toplabels*)
6138 > (fontcolor white (pr label)))))
6139 >
6140 > (def toplink (name dest label)
6141 > (tag-if (is name label) (span class 'topsel)
6142 > (link name dest)))
6143 >
6144 > (def topright (user whence (o showkarma t))
6145 > (when user
6146 > (userlink user user nil)
6147 > (when showkarma (pr " (@(karma user))"))
6148 > (pr " | "))
6149 > (if user
6150 > (rlinkf 'logout (req)
6151 > (when-umatch/r user req
6152 > (logout-user user)
6153 > whence))
6154 > (onlink "login"
6155 > (login-page 'both nil
6156 > (list (fn (u ip)
6157 > (ensure-news-user u)
6158 > (newslog ip u 'top-login))
6159 > whence)))))
6160 >
6161 > (def noob (user)
6162 > (and user (< (days-since (uvar user created)) 1)))
6163 >
6164 >
6165 > ; News-Specific Defop Variants
6166 >
6167 > (mac defopt (name parm test msg . body)
6168 > `(defop ,name ,parm
6169 > (if (,test (get-user ,parm))
6170 > (do ,@body)
6171 > (login-page 'both (+ "Please log in" ,msg ".")
6172 > (list (fn (u ip) (ensure-news-user u))
6173 > (string ',name (reassemble-args ,parm)))))))
6174 >
6175 > (mac defopg (name parm . body)
6176 > `(defopt ,name ,parm idfn "" ,@body))
6177 >
6178 > (mac defope (name parm . body)
6179 > `(defopt ,name ,parm editor " as an editor" ,@body))
6180 >
6181 > (mac defopa (name parm . body)
6182 > `(defopt ,name ,parm admin " as an administrator" ,@body))
6183 >
6184 > (mac opexpand (definer name parms . body)
6185 > (w/uniq gr
6186 > `(,definer ,name ,gr
6187 > (with (user (get-user ,gr) ip (,gr 'ip))
6188 > (with ,(and parms (mappend [list _ (list 'arg gr (string _))]
6189 > parms))
6190 > (newslog ip user ',name ,@parms)
6191 > ,@body)))))
6192 >
6193 > (= newsop-names* nil)
6194 >
6195 > (mac newsop args
6196 > `(do (pushnew ',(car args) newsop-names*)
6197 > (opexpand defop ,@args)))
6198 >
6199 > (mac adop (name parms . body)
6200 > (w/uniq g
6201 > `(opexpand defopa ,name ,parms
6202 > (let ,g (string ',name)
6203 > (shortpage user nil ,g ,g ,g
6204 > ,@body)))))
6205 >
6206 > (mac edop (name parms . body)
6207 > (w/uniq g
6208 > `(opexpand defope ,name ,parms
6209 > (let ,g (string ',name)
6210 > (shortpage user nil ,g ,g ,g
6211 > ,@body)))))
6212 >
6213 >
6214 > ; News Admin
6215 >
6216 > (defopa newsadmin req
6217 > (let user (get-user req)
6218 > (newslog req!ip user 'newsadmin)
6219 > (newsadmin-page user)))
6220 >
6221 > ; Note that caching* is reset to val in source when restart server.
6222 >
6223 > (def nad-fields ()
6224 > `((num caching ,caching* t t)
6225 > (bigtoks comment-kill ,comment-kill* t t)
6226 > (bigtoks comment-ignore ,comment-ignore* t t)
6227 > (bigtoks lightweights ,(sort < (keys lightweights*)) t t)))
6228 >
6229 > ; Need a util like vars-form for a collection of variables.
6230 > ; Or could generalize vars-form to think of places (in the setf sense).
6231 >
6232 > (def newsadmin-page (user)
6233 > (shortpage user nil nil "newsadmin" "newsadmin"
6234 > (vars-form user
6235 > (nad-fields)
6236 > (fn (name val)
6237 > (case name
6238 > caching (= caching* val)
6239 > comment-kill (todisk comment-kill* val)
6240 > comment-ignore (todisk comment-ignore* val)
6241 > lightweights (todisk lightweights* (memtable val))
6242 > ))
6243 > (fn () (newsadmin-page user)))
6244 > (br2)
6245 > (aform (fn (req)
6246 > (with (user (get-user req) subject (arg req "id"))
6247 > (if (profile subject)
6248 > (do (killallby subject)
6249 > (submitted-page user subject))
6250 > (admin&newsadmin-page user))))
6251 > (single-input "" 'id 20 "kill all by"))
6252 > (br2)
6253 > (aform (fn (req)
6254 > (let user (get-user req)
6255 > (set-ip-ban user (arg req "ip") t)
6256 > (admin&newsadmin-page user)))
6257 > (single-input "" 'ip 20 "ban ip"))))
6258 >
6259 >
6260 > ; Users
6261 >
6262 > (newsop user (id)
6263 > (if (only.profile id)
6264 > (user-page user id)
6265 > (pr "No such user.")))
6266 >
6267 > (def user-page (user subject)
6268 > (let here (user-url subject)
6269 > (shortpage user nil nil (+ "Profile: " subject) here
6270 > (profile-form user subject)
6271 > (br2)
6272 > (when (some astory:item (uvar subject submitted))
6273 > (underlink "submissions" (submitted-url subject)))
6274 > (when (some acomment:item (uvar subject submitted))
6275 > (sp)
6276 > (underlink "comments" (threads-url subject)))
6277 > (hook 'user user subject))))
6278 >
6279 > (def profile-form (user subject)
6280 > (let prof (profile subject)
6281 > (vars-form user
6282 > (user-fields user subject)
6283 > (fn (name val)
6284 > (when (and (is name 'ignore) val (no prof!ignore))
6285 > (log-ignore user subject 'profile))
6286 > (= (prof name) val))
6287 > (fn () (save-prof subject)
6288 > (user-page user subject)))))
6289 >
6290 > (= topcolor-threshold* 250)
6291 >
6292 > (def user-fields (user subject)
6293 > (withs (e (editor user)
6294 > a (admin user)
6295 > w (is user subject)
6296 > k (and w (> (karma user) topcolor-threshold*))
6297 > u (or a w)
6298 > m (or a (and (member user) w))
6299 > p (profile subject))
6300 > `((string user ,subject t nil)
6301 > (string name ,(p 'name) ,m ,m)
6302 > (string created ,(text-age:user-age subject) t nil)
6303 > (string password ,(resetpw-link) ,w nil)
6304 > (string saved ,(saved-link user subject) ,u nil)
6305 > (int auth ,(p 'auth) ,e ,a)
6306 > (yesno member ,(p 'member) ,a ,a)
6307 > (posint karma ,(p 'karma) t ,a)
6308 > (num avg ,(p 'avg) ,a nil)
6309 > (yesno ignore ,(p 'ignore) ,e ,e)
6310 > (num weight ,(p 'weight) ,a ,a)
6311 > (mdtext2 about ,(p 'about) t ,u)
6312 > (string email ,(p 'email) ,u ,u)
6313 > (yesno showdead ,(p 'showdead) ,u ,u)
6314 > (yesno noprocrast ,(p 'noprocrast) ,u ,u)
6315 > (string firstview ,(p 'firstview) ,a nil)
6316 > (string lastview ,(p 'lastview) ,a nil)
6317 > (posint maxvisit ,(p 'maxvisit) ,u ,u)
6318 > (posint minaway ,(p 'minaway) ,u ,u)
6319 > (sexpr keys ,(p 'keys) ,a ,a)
6320 > (hexcol topcolor ,(or (p 'topcolor) (hexrep site-color*)) ,k ,k)
6321 > (int delay ,(p 'delay) ,u ,u))))
6322 >
6323 > (def saved-link (user subject)
6324 > (when (or (admin user) (is user subject))
6325 > (let n (if (len> (votes subject) 500)
6326 > "many"
6327 > (len (voted-stories user subject)))
6328 > (if (is n 0)
6329 > ""
6330 > (tostring (underlink n (saved-url subject)))))))
6331 >
6332 > (def resetpw-link ()
6333 > (tostring (underlink "reset password" "resetpw")))
6334 >
6335 > (newsop welcome ()
6336 > (pr "Welcome to " this-site* ", " user "!"))
6337 >
6338 >
6339 > ; Main Operators
6340 >
6341 > ; remember to set caching to 0 when testing non-logged-in
6342 >
6343 > (= caching* 1 perpage* 30 threads-perpage* 10 maxend* 210)
6344 >
6345 > ; Limiting that newscache can't take any arguments except the user.
6346 > ; To allow other arguments, would have to turn the cache from a single
6347 > ; stored value to a hash table whose keys were lists of arguments.
6348 >
6349 > (mac newscache (name user time . body)
6350 > (w/uniq gc
6351 > `(let ,gc (cache (fn () (* caching* ,time))
6352 > (fn () (tostring (let ,user nil ,@body))))
6353 > (def ,name (,user)
6354 > (if ,user
6355 > (do ,@body)
6356 > (pr (,gc)))))))
6357 >
6358 >
6359 > (newsop news () (newspage user))
6360 >
6361 > (newsop || () (newspage user))
6362 >
6363 > ;(newsop index.html () (newspage user))
6364 >
6365 > (newscache newspage user 90
6366 > (listpage user (msec) (topstories user maxend*) nil nil "news"))
6367 >
6368 > (def listpage (user t1 items label title (o url label) (o number t))
6369 > (hook 'listpage user)
6370 > (longpage user t1 nil label title url
6371 > (display-items user items label title url 0 perpage* number)))
6372 >
6373 >
6374 > (newsop newest () (newestpage user))
6375 >
6376 > ; Note: dead/deleted items will persist for the remaining life of the
6377 > ; cached page. If this were a prob, could make deletion clear caches.
6378 >
6379 > (newscache newestpage user 40
6380 > (listpage user (msec) (newstories user maxend*) "new" "New Links" "newest"))
6381 >
6382 > (def newstories (user n)
6383 > (retrieve n [cansee user _] stories*))
6384 >
6385 >
6386 > (newsop best () (bestpage user))
6387 >
6388 > (newscache bestpage user 1000
6389 > (listpage user (msec) (beststories user maxend*) "best" "Top Links"))
6390 >
6391 > ; As no of stories gets huge, could test visibility in fn sent to best.
6392 >
6393 > (def beststories (user n)
6394 > (bestn n (compare > realscore) (visible user stories*)))
6395 >
6396 >
6397 > (newsop noobstories () (noobspage user stories*))
6398 > (newsop noobcomments () (noobspage user comments*))
6399 >
6400 > (def noobspage (user source)
6401 > (listpage user (msec) (noobs user maxend* source) "noobs" "New Accounts"))
6402 >
6403 > (def noobs (user n source)
6404 > (retrieve n [and (cansee user _) (bynoob _)] source))
6405 >
6406 > (def bynoob (i)
6407 > (< (- (user-age i!by) (item-age i)) 2880))
6408 >
6409 >
6410 > (newsop bestcomments () (bestcpage user))
6411 >
6412 > (newscache bestcpage user 1000
6413 > (listpage user (msec) (bestcomments user maxend*)
6414 > "best comments" "Best Comments" "bestcomments" nil))
6415 >
6416 > (def bestcomments (user n)
6417 > (bestn n (compare > realscore) (visible user comments*)))
6418 >
6419 >
6420 > (newsop lists ()
6421 > (longpage user (msec) nil "lists" "Lists" "lists"
6422 > (sptab
6423 > (row (link "best") "Highest voted recent links.")
6424 > (row (link "active") "Most active current discussions.")
6425 > (row (link "bestcomments") "Highest voted recent comments.")
6426 > (row (link "noobstories") "Submissions from new accounts.")
6427 > (row (link "noobcomments") "Comments from new accounts.")
6428 > (when (admin user)
6429 > (map row:link
6430 > '(optimes topips flagged killed badguys badlogins goodlogins)))
6431 > (hook 'listspage user))))
6432 >
6433 >
6434 > (def saved-url (user) (+ "saved?id=" user))
6435 >
6436 > (newsop saved (id)
6437 > (if (only.profile id)
6438 > (savedpage user id)
6439 > (pr "No such user.")))
6440 >
6441 > (def savedpage (user subject)
6442 > (if (or (is user subject) (admin user))
6443 > (listpage user (msec)
6444 > (sort (compare < item-age) (voted-stories user subject))
6445 > "saved" "Saved Links" (saved-url subject))
6446 > (pr "Can't display that.")))
6447 >
6448 > (def voted-stories (user subject)
6449 > (keep [and (astory _) (cansee user _)]
6450 > (map item (keys:votes subject))))
6451 >
6452 >
6453 > ; Story Display
6454 >
6455 > (def display-items (user items label title whence
6456 > (o start 0) (o end perpage*) (o number))
6457 > (zerotable
6458 > (let n start
6459 > (each i (cut items start end)
6460 > (display-item (and number (++ n)) i user whence t)
6461 > (spacerow (if (acomment i) 15 5))))
6462 > (when end
6463 > (let newend (+ end perpage*)
6464 > (when (and (<= newend maxend*) (< end (len items)))
6465 > (spacerow 10)
6466 > (tr (tag (td colspan (if number 2 1)))
6467 > (tag (td class 'title)
6468 > (morelink display-items
6469 > items label title end newend number))))))))
6470 >
6471 > ; This code is inevitably complex because the More fn needs to know
6472 > ; its own fnid in order to supply a correct whence arg to stuff on
6473 > ; the page it generates, like logout and delete links.
6474 >
6475 > (def morelink (f items label title . args)
6476 > (tag (a href
6477 > (url-for
6478 > (afnid (fn (req)
6479 > (prn)
6480 > (with (url (url-for it) ; it bound by afnid
6481 > user (get-user req))
6482 > (newslog req!ip user 'more label)
6483 > (longpage user (msec) nil label title url
6484 > (apply f user items label title url args))))))
6485 > rel 'nofollow)
6486 > (pr "More")))
6487 >
6488 > (def display-story (i s user whence)
6489 > (when (or (cansee user s) (s 'kids))
6490 > (tr (display-item-number i)
6491 > (td (votelinks s user whence))
6492 > (titleline s s!url user whence))
6493 > (tr (tag (td colspan (if i 2 1)))
6494 > (tag (td class 'subtext)
6495 > (hook 'itemline s user)
6496 > (itemline s user)
6497 > (when (in s!type 'story 'poll) (commentlink s user))
6498 > (editlink s user)
6499 > (when (apoll s) (addoptlink s user))
6500 > (unless i (flaglink s user whence))
6501 > (killlink s user whence)
6502 > (blastlink s user whence)
6503 > (blastlink s user whence t)
6504 > (deletelink s user whence)))))
6505 >
6506 > (def display-item-number (i)
6507 > (when i (tag (td align 'right valign 'top class 'title)
6508 > (pr i "."))))
6509 >
6510 > (= follow-threshold* 5)
6511 >
6512 > (def titleline (s url user whence)
6513 > (tag (td class 'title)
6514 > (if (cansee user s)
6515 > (do (deadmark s user)
6516 > (titlelink s url user)
6517 > (pdflink url)
6518 > (awhen (sitename url)
6519 > (spanclass comhead
6520 > (pr " (" )
6521 > (if (admin user)
6522 > (w/rlink (do (set-site-ban user
6523 > it
6524 > (case (car (banned-sites* it))
6525 > nil 'ignore
6526 > ignore 'kill
6527 > kill nil))
6528 > whence)
6529 > (let ban (car (banned-sites* it))
6530 > (tag-if ban (font color (case ban
6531 > ignore darkred
6532 > kill darkblue))
6533 > (pr it))))
6534 > (pr it))
6535 > (pr ") "))))
6536 > (pr (pseudo-text s)))))
6537 >
6538 > (def titlelink (s url user)
6539 > (let toself (blank url)
6540 > (tag (a href (if toself
6541 > (item-url s!id)
6542 > (or (live s) (author user s) (editor user))
6543 > url
6544 > nil)
6545 > rel (unless (or toself (> (realscore s) follow-threshold*))
6546 > 'nofollow))
6547 > (pr s!title))))
6548 >
6549 > (def pdflink (url)
6550 > (awhen (vacuumize url)
6551 > (pr " [")
6552 > (link "scribd" it)
6553 > (pr "]")))
6554 >
6555 > (defmemo vacuumize (url)
6556 > (and (or (endmatch ".pdf" url) (endmatch ".PDF" url))
6557 > (+ "http://www.scribd.com/vacuum?url=" url)))
6558 >
6559 > (def pseudo-text (i)
6560 > (if i!deleted "[deleted]" "[dead]"))
6561 >
6562 > (def deadmark (i user)
6563 > (when (and i!dead (seesdead user))
6564 > (pr " [dead] "))
6565 > (when (and i!deleted (admin user))
6566 > (pr " [deleted] ")))
6567 >
6568 > (= downvote-threshold* 200 downvote-time* 1440)
6569 >
6570 > (= votewid* 14)
6571 >
6572 > (def votelinks (i user whence (o downtoo))
6573 > (center
6574 > (if (and (cansee user i)
6575 > (or (no user)
6576 > (no ((votes user) i!id))))
6577 > (do (votelink i user whence 'up)
6578 > (if (and downtoo
6579 > (or (admin user)
6580 > (< (item-age i) downvote-time*))
6581 > (canvote user i 'down))
6582 > (do (br)
6583 > (votelink i user whence 'down))
6584 > ; don't understand why needed, but is, or a new
6585 > ; page is generated on voting
6586 > (tag (span id (+ "down_" i!id)))))
6587 > (author user i)
6588 > (do (fontcolor orange (pr "*"))
6589 > (br)
6590 > (hspace votewid*))
6591 > (hspace votewid*))))
6592 >
6593 > ; could memoize votelink more, esp for non-logged in users,
6594 > ; since only uparrow is shown; could straight memoize
6595 >
6596 > ; redefined later (identically) so the outs catch new vals of up-url, etc.
6597 >
6598 > (def votelink (i user whence dir)
6599 > (tag (a id (if user (string dir '_ i!id))
6600 > onclick (if user "return vote(this)")
6601 > href (vote-url user i dir whence))
6602 > (if (is dir 'up)
6603 > (out (gentag img src up-url* border 0 vspace 3 hspace 2))
6604 > (out (gentag img src down-url* border 0 vspace 3 hspace 2)))))
6605 >
6606 > (def vote-url (user i dir whence)
6607 > (+ "vote?" "for=" i!id
6608 > "&dir=" dir
6609 > (if user (+ "&by=" user "&auth=" (user->cookie* user)))
6610 > "&whence=" (urlencode whence)))
6611 >
6612 > (= lowest-score* -4)
6613 >
6614 > ; Not much stricter than whether to generate the arrow. Further tests
6615 > ; applied in vote-for.
6616 >
6617 > (def canvote (user i dir)
6618 > (and user
6619 > (news-type&live i)
6620 > (or (is dir 'up) (> i!score lowest-score*))
6621 > (no ((votes user) i!id))
6622 > (or (is dir 'up)
6623 > (and (acomment i)
6624 > (> (karma user) downvote-threshold*)
6625 > (no (aand i!parent (author user (item it))))))))
6626 >
6627 > ; Need the by argument or someone could trick logged in users into
6628 > ; voting something up by clicking on a link. But a bad guy doesn't
6629 > ; know how to generate an auth arg that matches each user's cookie.
6630 >
6631 > (newsop vote (by for dir auth whence)
6632 > (with (i (safe-item for)
6633 > dir (saferead dir)
6634 > whence (if whence (urldecode whence) "news"))
6635 > (if (no i)
6636 > (pr "No such item.")
6637 > (no (in dir 'up 'down))
6638 > (pr "Can't make that vote.")
6639 > (and by (or (isnt by user) (isnt (sym auth) (user->cookie* user))))
6640 > (pr "User mismatch.")
6641 > (no user)
6642 > (login-page 'both "You have to be logged in to vote."
6643 > (list (fn (u ip)
6644 > (ensure-news-user u)
6645 > (newslog ip u 'vote-login)
6646 > (when (canvote u i dir)
6647 > (vote-for u i dir)
6648 > (logvote ip u i)))
6649 > whence))
6650 > (canvote user i dir)
6651 > (do (vote-for by i dir)
6652 > (logvote ip by i))
6653 > (pr "Can't make that vote."))))
6654 >
6655 > (def itemline (i user)
6656 > (when (cansee user i)
6657 > (when (news-type i) (itemscore i user))
6658 > (byline i user)))
6659 >
6660 > (def itemscore (i (o user))
6661 > (tag (span id (+ "score_" i!id))
6662 > (pr (plural (if (is i!type 'pollopt) (realscore i) i!score)
6663 > "point")))
6664 > (hook 'itemscore i user))
6665 >
6666 > ; redefined later
6667 >
6668 > (def byline (i user)
6669 > (pr " by @(tostring (userlink user i!by)) @(text-age:item-age i) "))
6670 >
6671 > (def user-url (user) (+ "user?id=" user))
6672 >
6673 > (= show-avg* nil)
6674 >
6675 > (def userlink (user subject (o show-avg t))
6676 > (link (user-name user subject) (user-url subject))
6677 > (awhen (and show-avg* (admin user) show-avg (uvar subject avg))
6678 > (pr " (@(num it 1 t t))")))
6679 >
6680 > (= noob-color* (color 60 150 60))
6681 >
6682 > (def user-name (user subject)
6683 > (if (and (editor user) (ignored subject))
6684 > (tostring (fontcolor darkred (pr subject)))
6685 > (and (editor user) (< (user-age subject) 1440))
6686 > (tostring (fontcolor noob-color* (pr subject)))
6687 > subject))
6688 >
6689 > (= show-threadavg* nil)
6690 >
6691 > (def commentlink (i user)
6692 > (when (cansee user i)
6693 > (pr bar*)
6694 > (tag (a href (item-url i!id))
6695 > (let n (- (visible-family user i) 1)
6696 > (if (> n 0)
6697 > (do (pr (plural n "comment"))
6698 > (awhen (and show-threadavg* (admin user) (threadavg i))
6699 > (pr " (@(num it 1 t t))")))
6700 > (pr "discuss"))))))
6701 >
6702 > (def visible-family (user i)
6703 > (+ (if (cansee user i) 1 0)
6704 > (sum [visible-family user (item _)] i!kids)))
6705 >
6706 > (def threadavg (i)
6707 > (only.avg (map [or (uvar _ avg) 1]
6708 > (rem admin (dedup (map !by (keep live (family i))))))))
6709 >
6710 > (= user-changetime* 120 editor-changetime* 1440)
6711 >
6712 > (= everchange* (table) noedit* (table))
6713 >
6714 > (def canedit (user i)
6715 > (or (admin user)
6716 > (and (~noedit* i!type)
6717 > (editor user)
6718 > (< (item-age i) editor-changetime*))
6719 > (own-changeable-item user i)))
6720 >
6721 > (def own-changeable-item (user i)
6722 > (and (author user i)
6723 > (~mem 'locked i!keys)
6724 > (no i!deleted)
6725 > (or (everchange* i!type)
6726 > (< (item-age i) user-changetime*))))
6727 >
6728 > (def editlink (i user)
6729 > (when (canedit user i)
6730 > (pr bar*)
6731 > (link "edit" (edit-url i))))
6732 >
6733 > (def addoptlink (p user)
6734 > (when (or (admin user) (author user p))
6735 > (pr bar*)
6736 > (onlink "add choice" (add-pollopt-page p user))))
6737 >
6738 > ; reset later
6739 >
6740 > (= flag-threshold* 30 flag-kill-threshold* 7 many-flags* 1)
6741 >
6742 > ; Un-flagging something doesn't unkill it, if it's now no longer
6743 > ; over flag-kill-threshold. Ok, since arbitrary threshold anyway.
6744 >
6745 > (def flaglink (i user whence)
6746 > (when (and user
6747 > (isnt user i!by)
6748 > (or (admin user) (> (karma user) flag-threshold*)))
6749 > (pr bar*)
6750 > (w/rlink (do (togglemem user i!flags)
6751 > (when (and (~mem 'nokill i!keys)
6752 > (len> i!flags flag-kill-threshold*)
6753 > (< (realscore i) 10)
6754 > (~find admin:!2 i!vote))
6755 > (kill i 'flags))
6756 > whence)
6757 > (pr "@(if (mem user i!flags) 'un)flag"))
6758 > (when (and (admin user) (len> i!flags many-flags*))
6759 > (pr bar* (plural (len i!flags) "flag") " ")
6760 > (w/rlink (do (togglemem 'nokill i!keys)
6761 > (save-item i)
6762 > whence)
6763 > (pr (if (mem 'nokill i!keys) "un-notice" "noted"))))))
6764 >
6765 > (def killlink (i user whence)
6766 > (when (admin user)
6767 > (pr bar*)
6768 > (w/rlink (do (zap no i!dead)
6769 > (if i!dead
6770 > (do (pull 'nokill i!keys)
6771 > (log-kill i user))
6772 > (pushnew 'nokill i!keys))
6773 > (save-item i)
6774 > whence)
6775 > (pr "@(if i!dead 'un)kill"))))
6776 >
6777 > ; Blast kills the submission and bans the user. Nuke also bans the
6778 > ; site, so that all future submitters will be ignored. Does not ban
6779 > ; the ip address, but that will eventually get banned by maybe-ban-ip.
6780 >
6781 > (def blastlink (i user whence (o nuke))
6782 > (when (and (admin user)
6783 > (or (no nuke) (~empty i!url)))
6784 > (pr bar*)
6785 > (w/rlink (do (toggle-blast i user nuke)
6786 > whence)
6787 > (prt (if (ignored i!by) "un-") (if nuke "nuke" "blast")))))
6788 >
6789 > (def toggle-blast (i user (o nuke))
6790 > (atomic
6791 > (if (ignored i!by)
6792 > (do (wipe i!dead (ignored i!by))
6793 > (awhen (and nuke (sitename i!url))
6794 > (set-site-ban user it nil)))
6795 > (do (set i!dead)
6796 > (ignore user i!by (if nuke 'nuke 'blast))
6797 > (awhen (and nuke (sitename i!url))
6798 > (set-site-ban user it 'ignore))))
6799 > (if i!dead (log-kill i user))
6800 > (save-item i)
6801 > (save-prof i!by)))
6802 >
6803 > (def candelete (user i)
6804 > (or (admin user) (own-changeable-item user i)))
6805 >
6806 > (def deletelink (i user whence)
6807 > (when (candelete user i)
6808 > (pr bar*)
6809 > (linkf (if i!deleted "undelete" "delete") (req)
6810 > (let user (get-user req)
6811 > (if (candelete user i)
6812 > (del-confirm-page user i whence)
6813 > (prn "You can't delete that."))))))
6814 >
6815 > ; Undeleting stories could cause a slight inconsistency. If a story
6816 > ; linking to x gets deleted, another submission can take its place in
6817 > ; url->story. If the original is then undeleted, there will be two
6818 > ; stories with equal claim to be in url->story. (The more recent will
6819 > ; win because it happens to get loaded later.) Not a big problem.
6820 >
6821 > (def del-confirm-page (user i whence)
6822 > (minipage "Confirm"
6823 > (tab
6824 > ; link never used so not testable but think correct
6825 > (display-item nil i user (flink [del-confirm-page (get-user _) i whence]))
6826 > (spacerow 20)
6827 > (tr (td)
6828 > (td (urform user req
6829 > (do (when (candelete user i)
6830 > (= i!deleted (is (arg req "b") "Yes"))
6831 > (save-item i))
6832 > whence)
6833 > (prn "Do you want this to @(if i!deleted 'stay 'be) deleted?")
6834 > (br2)
6835 > (but "Yes" "b") (sp) (but "No" "b")))))))
6836 >
6837 > (def permalink (story user)
6838 > (when (cansee user story)
6839 > (pr bar*)
6840 > (link "link" (item-url story!id))))
6841 >
6842 > (def logvote (ip user story)
6843 > (newslog ip user 'vote (story 'id) (list (story 'title))))
6844 >
6845 > (def text-age (a)
6846 > (tostring
6847 > (if (>= a 1440) (pr (plural (trunc (/ a 1440)) "day") " ago")
6848 > (>= a 60) (pr (plural (trunc (/ a 60)) "hour") " ago")
6849 > (pr (plural (trunc a) "minute") " ago"))))
6850 >
6851 >
6852 > ; Voting
6853 >
6854 > ; A user needs legit-threshold karma for a vote to count if there has
6855 > ; already been a vote from the same IP address. A new account below both
6856 > ; new- thresholds won't affect rankings, though such votes still affect
6857 > ; scores unless not a legit-user.
6858 >
6859 > (= legit-threshold* 0 new-age-threshold* 0 new-karma-threshold* 2)
6860 >
6861 > (def legit-user (user)
6862 > (or (editor user)
6863 > (> (karma user) legit-threshold*)))
6864 >
6865 > (def possible-sockpuppet (user)
6866 > (or (ignored user)
6867 > (< (uvar user weight) .5)
6868 > (and (< (user-age user) new-age-threshold*)
6869 > (< (karma user) new-karma-threshold*))))
6870 >
6871 > (= downvote-ratio-limit* .65 recent-votes* nil votewindow* 100)
6872 >
6873 > ; Note: if vote-for by one user changes (s 'score) while s is being
6874 > ; edited by another, the save after the edit will overwrite the change.
6875 > ; Actual votes can't be lost because that field is not editable. Not a
6876 > ; big enough problem to drag in locking.
6877 >
6878 > (def vote-for (user i (o dir 'up))
6879 > (unless (or ((votes user) i!id)
6880 > (and (~live i) (isnt user i!by)))
6881 > (withs (ip (logins* user)
6882 > vote (list (seconds) ip user dir i!score))
6883 > (unless (or (and (or (ignored user) (check-key user 'novote))
6884 > (isnt user i!by))
6885 > (and (is dir 'down)
6886 > (~editor user)
6887 > (or (check-key user 'nodowns)
6888 > (> (downvote-ratio user) downvote-ratio-limit*)
6889 > ; prevention of karma-bombing
6890 > (just-downvoted user i!by)))
6891 > (and (~legit-user user)
6892 > (isnt user i!by)
6893 > (find [is (cadr _) ip] i!votes))
6894 > (and (isnt i!type 'pollopt)
6895 > (biased-voter i vote)))
6896 > (++ i!score (case dir up 1 down -1))
6897 > ; canvote protects against sockpuppet downvote of comments
6898 > (when (and (is dir 'up) (possible-sockpuppet user))
6899 > (++ i!sockvotes))
6900 > (metastory&adjust-rank i)
6901 > (unless (or (author user i)
6902 > (and (is ip i!ip) (~editor user))
6903 > (is i!type 'pollopt))
6904 > (++ (karma i!by) (case dir up 1 down -1))
6905 > (save-prof i!by))
6906 > (wipe (comment-cache* i!id)))
6907 > (if (admin user) (pushnew 'nokill i!keys))
6908 > (push vote i!votes)
6909 > (save-item i)
6910 > (push (list (seconds) i!id i!by (sitename i!url) dir)
6911 > (uvar user votes))
6912 > (= ((votes* user) i!id) vote)
6913 > (save-votes user)
6914 > (zap [firstn votewindow* _] (uvar user votes))
6915 > (save-prof user)
6916 > (push (cons i!id vote) recent-votes*))))
6917 >
6918 > ; redefined later
6919 >
6920 > (def biased-voter (i vote) nil)
6921 >
6922 > ; ugly to access vote fields by position number
6923 >
6924 > (def downvote-ratio (user (o sample 20))
6925 > (ratio [is _.1.3 'down]
6926 > (keep [let by ((item (car _)) 'by)
6927 > (nor (is by user) (ignored by))]
6928 > (bestn sample (compare > car:cadr) (tablist (votes user))))))
6929 >
6930 > (def just-downvoted (user victim (o n 3))
6931 > (let prev (firstn n (recent-votes-by user))
6932 > (and (is (len prev) n)
6933 > (all (fn ((id sec ip voter dir score))
6934 > (and (author victim (item id)) (is dir 'down)))
6935 > prev))))
6936 >
6937 > ; Ugly to pluck out fourth element. Should read votes into a vote
6938 > ; template. They're stored slightly differently in two diff places:
6939 > ; in one with the voter in the car and the other without.
6940 >
6941 > (def recent-votes-by (user)
6942 > (keep [is _.3 user] recent-votes*))
6943 >
6944 >
6945 > ; Story Submission
6946 >
6947 > (newsop submit ()
6948 > (if user
6949 > (submit-page user "" "" t)
6950 > (submit-login-warning "" "" t)))
6951 >
6952 > (def submit-login-warning ((o url) (o title) (o showtext) (o text))
6953 > (login-page 'both "You have to be logged in to submit."
6954 > (fn (user ip)
6955 > (ensure-news-user user)
6956 > (newslog ip user 'submit-login)
6957 > (submit-page user url title showtext text))))
6958 >
6959 > (def submit-page (user (o url) (o title) (o showtext) (o text "") (o msg))
6960 > (minipage "Submit"
6961 > (pagemessage msg)
6962 > (urform user req
6963 > (process-story (get-user req)
6964 > (clean-url (arg req "u"))
6965 > (striptags (arg req "t"))
6966 > showtext
6967 > (and showtext (md-from-form (arg req "x") t))
6968 > req!ip)
6969 > (tab
6970 > (row "title" (input "t" title 50))
6971 > (if prefer-url*
6972 > (do (row "url" (input "u" url 50))
6973 > (when showtext
6974 > (row "" "or ")
6975 > (row "text" (textarea "x" 4 50 (only.pr text)))))
6976 > (do (row "text" (textarea "x" 4 50 (only.pr text)))
6977 > (row "" "or ")
6978 > (row "url" (input "u" url 50))))
6979 > (row "" (submit))
6980 > (spacerow 20)
6981 > (row "" submit-instructions*)))))
6982 >
6983 > (= submit-instructions*
6984 > "Leave url blank to submit a question for discussion. If there is
6985 > no url, the text (if any) will appear at the top of the comments
6986 > page. If there is a url, the text will be ignored.")
6987 >
6988 > ; For use by outside code like bookmarklet.
6989 > ; http://news.domain.com/submitlink?u=http://foo.com&t=Foo
6990 > ; Added a confirm step to avoid xss hacks.
6991 >
6992 > (newsop submitlink (u t)
6993 > (if user
6994 > (submit-page user u t)
6995 > (submit-login-warning u t)))
6996 >
6997 > (= title-limit* 80
6998 > retry* "Please try again."
6999 > toolong* "Please make title < @title-limit* characters."
7000 > bothblank* "The url and text fields can't both be blank. Please
7001 > either supply a url, or if you're asking a question,
7002 > put it in the text field."
7003 > toofast* "You're submitting too fast. Please slow down. Thanks."
7004 > spammage* "Stop spamming us. You're wasting your time.")
7005 >
7006 > ; Only for annoyingly high-volume spammers. For ordinary spammers it's
7007 > ; enough to ban their sites and ip addresses.
7008 >
7009 > (disktable big-spamsites* (+ newsdir* "big-spamsites"))
7010 >
7011 > (def process-story (user url title showtext text ip)
7012 > (aif (and (~blank url) (live-story-w/url url))
7013 > (do (vote-for user it)
7014 > (item-url it!id))
7015 > (if (no user)
7016 > (flink [submit-login-warning url title showtext text])
7017 > (no (and (or (blank url) (valid-url url))
7018 > (~blank title)))
7019 > (flink [submit-page user url title showtext text retry*])
7020 > (len> title title-limit*)
7021 > (flink [submit-page user url title showtext text toolong*])
7022 > (and (blank url) (blank text))
7023 > (flink [submit-page user url title showtext text bothblank*])
7024 > (let site (sitename url)
7025 > (or (big-spamsites* site) (recent-spam site)))
7026 > (flink [msgpage user spammage*])
7027 > (oversubmitting user ip 'story url)
7028 > (flink [msgpage user toofast*])
7029 > (let s (create-story url (process-title title) text user ip)
7030 > (story-ban-test user s ip url)
7031 > (when (ignored user) (kill s 'ignored))
7032 > (submit-item user s)
7033 > (maybe-ban-ip s)
7034 > "newest"))))
7035 >
7036 > (def submit-item (user i)
7037 > (push i!id (uvar user submitted))
7038 > (save-prof user)
7039 > (vote-for user i))
7040 >
7041 > (def recent-spam (site)
7042 > (and (caris (banned-sites* site) 'ignore)
7043 > (recent-items [is (sitename _!url) site] 720)))
7044 >
7045 > (def recent-items (test minutes)
7046 > (let cutoff (- (seconds) (* 60 minutes))
7047 > (latest-items test [< _!time cutoff])))
7048 >
7049 > ; Turn this on when spam becomes a problem.
7050 >
7051 > (= enforce-oversubmit* nil)
7052 >
7053 > ; New user can't submit more than 2 stories in a 2 hour period.
7054 > ; Give overeager users the key toofast to make limit permanent.
7055 >
7056 > (def oversubmitting (user ip kind (o url))
7057 > (and enforce-oversubmit*
7058 > (or (check-key user 'toofast)
7059 > (ignored user)
7060 > (< (user-age user) new-age-threshold*)
7061 > (< (karma user) new-karma-threshold*))
7062 > (len> (recent-items [or (author user _) (is _!ip ip)] 180)
7063 > (if (is kind 'story)
7064 > (if (bad-user user) 0 1)
7065 > (if (bad-user user) 1 10)))))
7066 >
7067 > ; Note that by deliberate tricks, someone could submit a story with a
7068 > ; blank title.
7069 >
7070 > (diskvar scrubrules* (+ newsdir* "scrubrules"))
7071 >
7072 > (def process-title (s)
7073 > (let s2 (multisubst scrubrules* s)
7074 > (zap upcase (s2 0))
7075 > s2))
7076 >
7077 > (def live-story-w/url (url)
7078 > (aand (url->story* (canonical-url url)) (check (item it) live)))
7079 >
7080 > (def parse-site (url)
7081 > (rev (tokens (cadr (tokens url [in _ #\/ #\?])) #\.)))
7082 >
7083 > (defmemo sitename (url)
7084 > (and (valid-url url)
7085 > (let toks (parse-site (rem #\space url))
7086 > (if (isa (saferead (car toks)) 'int)
7087 > (tostring (prall toks "" "."))
7088 > (let (t1 t2 t3 . rest) toks
7089 > (if (and (~in t3 nil "www")
7090 > (or (mem t1 multi-tld-countries*)
7091 > (mem t2 long-domains*)))
7092 > (+ t3 "." t2 "." t1)
7093 > (and t2 (+ t2 "." t1))))))))
7094 >
7095 > (= multi-tld-countries* '("uk" "jp" "au" "in" "ph" "tr" "za" "my" "nz" "br"
7096 > "mx" "th" "sg" "id" "pk" "eg" "il" "at" "pl"))
7097 >
7098 > (= long-domains* '("blogspot" "wordpress" "livejournal" "blogs" "typepad"
7099 > "weebly" "posterous" "blog-city" "supersized" "dreamhosters"
7100 > ; "sampasite" "multiply" "wetpaint" ; all spam, just ban
7101 > "eurekster" "blogsome" "edogo" "blog" "com"))
7102 >
7103 > (def create-story (url title text user ip)
7104 > (newslog ip user 'create url (list title))
7105 > (let s (inst 'item 'type 'story 'id (new-item-id)
7106 > 'url url 'title title 'text text 'by user 'ip ip)
7107 > (save-item s)
7108 > (= (items* s!id) s)
7109 > (unless (blank url) (register-url s url))
7110 > (push s stories*)
7111 > s))
7112 >
7113 >
7114 > ; Bans
7115 >
7116 > (def ignore (user subject cause)
7117 > (set (ignored subject))
7118 > (save-prof subject)
7119 > (log-ignore user subject cause))
7120 >
7121 > (diskvar ignore-log* (+ newsdir* "ignore-log"))
7122 >
7123 > (def log-ignore (user subject cause)
7124 > (todisk ignore-log* (cons (list subject user cause) ignore-log*)))
7125 >
7126 > ; Kill means stuff with this substring gets killed. Ignore is stronger,
7127 > ; means that user will be auto-ignored. Eventually this info should
7128 > ; be stored on disk and not in the source code.
7129 >
7130 > (disktable banned-ips* (+ newsdir* "banned-ips")) ; was ips
7131 > (disktable banned-sites* (+ newsdir* "banned-sites")) ; was sites
7132 >
7133 > (diskvar comment-kill* (+ newsdir* "comment-kill"))
7134 > (diskvar comment-ignore* (+ newsdir* "comment-ignore"))
7135 >
7136 > (= comment-kill* nil ip-ban-threshold* 3)
7137 >
7138 > (def set-ip-ban (user ip yesno (o info))
7139 > (= (banned-ips* ip) (and yesno (list user (seconds) info)))
7140 > (todisk banned-ips*))
7141 >
7142 > (def set-site-ban (user site ban (o info))
7143 > (= (banned-sites* site) (and ban (list ban user (seconds) info)))
7144 > (todisk banned-sites*))
7145 >
7146 > ; Kill submissions from banned ips, but don't auto-ignore users from
7147 > ; them, because eventually ips will become legit again.
7148 >
7149 > ; Note that ban tests are only applied when a link or comment is
7150 > ; submitted, not each time it's edited. This will do for now.
7151 >
7152 > (def story-ban-test (user i ip url)
7153 > (site-ban-test user i url)
7154 > (ip-ban-test i ip)
7155 > (hook 'story-ban-test user i ip url))
7156 >
7157 > (def site-ban-test (user i url)
7158 > (whenlet ban (banned-sites* (sitename url))
7159 > (if (caris ban 'ignore) (ignore nil user 'site-ban))
7160 > (kill i 'site-ban)))
7161 >
7162 > (def ip-ban-test (i ip)
7163 > (if (banned-ips* ip) (kill i 'banned-ip)))
7164 >
7165 > (def comment-ban-test (user i ip string kill-list ignore-list)
7166 > (when (some [posmatch _ string] ignore-list)
7167 > (ignore nil user 'comment-ban))
7168 > (when (or (banned-ips* ip) (some [posmatch _ string] kill-list))
7169 > (kill i 'comment-ban)))
7170 >
7171 > ; An IP is banned when multiple ignored users have submitted over
7172 > ; ban-threshold* (currently loaded) dead stories from it.
7173 >
7174 > ; Can consider comments too if that later starts to be a problem,
7175 > ; but the threshold may start to be higher because then you'd be
7176 > ; dealing with trolls rather than spammers.
7177 >
7178 > (def maybe-ban-ip (s)
7179 > (when (and s!dead (ignored s!by))
7180 > (let bads (loaded-items [and _!dead (astory _) (is _!ip s!ip)])
7181 > (when (and (len> bads ip-ban-threshold*)
7182 > (some [and (ignored _!by) (isnt _!by s!by)] bads))
7183 > (set-ip-ban nil s!ip t)))))
7184 >
7185 > (def killallby (user)
7186 > (map [kill _ 'all] (submissions user)))
7187 >
7188 > ; Only called from repl.
7189 >
7190 > (def kill-whole-thread (c)
7191 > (kill c 'thread)
7192 > (map kill-whole-thread:item c!kids))
7193 >
7194 >
7195 > ; Polls
7196 >
7197 > ; a way to add a karma threshold for voting in a poll
7198 > ; or better still an arbitrary test fn, or at least pair of name/threshold.
7199 > ; option to sort the elements of a poll when displaying
7200 > ; exclusive field? (means only allow one vote per poll)
7201 >
7202 > (= poll-threshold* 20)
7203 >
7204 > (newsop newpoll ()
7205 > (if (and user (> (karma user) poll-threshold*))
7206 > (newpoll-page user)
7207 > (pr "Sorry, you need @poll-threshold* karma to create a poll.")))
7208 >
7209 > (def newpoll-page (user (o title "Poll: ") (o text "") (o opts "") (o msg))
7210 > (minipage "New Poll"
7211 > (pagemessage msg)
7212 > (urform user req
7213 > (process-poll (get-user req)
7214 > (striptags (arg req "t"))
7215 > (md-from-form (arg req "x") t)
7216 > (striptags (arg req "o"))
7217 > req!ip)
7218 > (tab
7219 > (row "title" (input "t" title 50))
7220 > (row "text" (textarea "x" 4 50 (only.pr text)))
7221 > (row "" "Use blank lines to separate choices:")
7222 > (row "choices" (textarea "o" 7 50 (only.pr opts)))
7223 > (row "" (submit))))))
7224 >
7225 > (= fewopts* "A poll must have at least two options.")
7226 >
7227 > (def process-poll (user title text opts ip)
7228 > (if (or (blank title) (blank opts))
7229 > (flink [newpoll-page user title text opts retry*])
7230 > (len> title title-limit*)
7231 > (flink [newpoll-page user title text opts toolong*])
7232 > (len< (paras opts) 2)
7233 > (flink [newpoll-page user title text opts fewopts*])
7234 > (atlet p (create-poll (multisubst scrubrules* title) text opts user ip)
7235 > (ip-ban-test p ip)
7236 > (when (ignored user) (kill p 'ignored))
7237 > (submit-item user p)
7238 > (maybe-ban-ip p)
7239 > "newest")))
7240 >
7241 > (def create-poll (title text opts user ip)
7242 > (newslog ip user 'create-poll title)
7243 > (let p (inst 'item 'type 'poll 'id (new-item-id)
7244 > 'title title 'text text 'by user 'ip ip)
7245 > (= p!parts (map get!id (map [create-pollopt p nil nil _ user ip]
7246 > (paras opts))))
7247 > (save-item p)
7248 > (= (items* p!id) p)
7249 > (push p stories*)
7250 > p))
7251 >
7252 > (def create-pollopt (p url title text user ip)
7253 > (let o (inst 'item 'type 'pollopt 'id (new-item-id)
7254 > 'url url 'title title 'text text 'parent p!id
7255 > 'by user 'ip ip)
7256 > (save-item o)
7257 > (= (items* o!id) o)
7258 > o))
7259 >
7260 > (def add-pollopt-page (p user)
7261 > (minipage "Add Poll Choice"
7262 > (urform user req
7263 > (do (add-pollopt user p (striptags (arg req "x")) req!ip)
7264 > (item-url p!id))
7265 > (tab
7266 > (row "text" (textarea "x" 4 50))
7267 > (row "" (submit))))))
7268 >
7269 > (def add-pollopt (user p text ip)
7270 > (unless (blank text)
7271 > (atlet o (create-pollopt p nil nil text user ip)
7272 > (++ p!parts (list o!id))
7273 > (save-item p))))
7274 >
7275 > (def display-pollopts (p user whence)
7276 > (each o (visible user (map item p!parts))
7277 > (display-pollopt nil o user whence)
7278 > (spacerow 7)))
7279 >
7280 > (def display-pollopt (n o user whence)
7281 > (tr (display-item-number n)
7282 > (tag (td valign 'top)
7283 > (votelinks o user whence))
7284 > (tag (td class 'comment)
7285 > (tag (div style "margin-top:1px;margin-bottom:0px")
7286 > (if (~cansee user o) (pr (pseudo-text o))
7287 > (~live o) (spanclass dead
7288 > (pr (if (~blank o!title) o!title o!text)))
7289 > (if (and (~blank o!title) (~blank o!url))
7290 > (link o!title o!url)
7291 > (fontcolor black (pr o!text)))))))
7292 > (tr (if n (td))
7293 > (td)
7294 > (tag (td class 'default)
7295 > (spanclass comhead
7296 > (itemscore o)
7297 > (editlink o user)
7298 > (killlink o user whence)
7299 > (deletelink o user whence)
7300 > (deadmark o user)))))
7301 >
7302 >
7303 > ; Individual Item Page (= Comments Page of Stories)
7304 >
7305 > (defmemo item-url (id) (+ "item?id=" id))
7306 >
7307 > (newsop item (id)
7308 > (let s (safe-item id)
7309 > (if (news-type s)
7310 > (do (if s!deleted (note-baditem user ip))
7311 > (item-page user s))
7312 > (do (note-baditem user ip)
7313 > (pr "No such item.")))))
7314 >
7315 > (= baditemreqs* (table) baditem-threshold* 1/100)
7316 >
7317 > ; Something looking at a lot of deleted items is probably the bad sort
7318 > ; of crawler. Throttle it for this server invocation.
7319 >
7320 > (def note-baditem (user ip)
7321 > (unless (admin user)
7322 > (++ (baditemreqs* ip 0))
7323 > (with (r (requests/ip* ip) b (baditemreqs* ip))
7324 > (when (and (> r 500) (> (/ b r) baditem-threshold*))
7325 > (set (throttle-ips* ip))))))
7326 >
7327 > ; redefined later
7328 >
7329 > (def news-type (i) (and i (in i!type 'story 'comment 'poll 'pollopt)))
7330 >
7331 > (def item-page (user i)
7332 > (with (title (and (cansee user i)
7333 > (or i!title (aand i!text (ellipsize (striptags it)))))
7334 > here (item-url i!id))
7335 > (longpage user (msec) nil nil title here
7336 > (tab (display-item nil i user here)
7337 > (display-item-text i user)
7338 > (when (apoll i)
7339 > (spacerow 10)
7340 > (tr (td)
7341 > (td (tab (display-pollopts i user here)))))
7342 > (when (and (cansee user i) (comments-active i))
7343 > (spacerow 10)
7344 > (row "" (comment-form i user here))))
7345 > (br2)
7346 > (when (and i!kids (commentable i))
7347 > (tab (display-subcomments i user here))
7348 > (br2)))))
7349 >
7350 > (def commentable (i) (in i!type 'story 'comment 'poll))
7351 >
7352 > ; By default the ability to comment on an item is turned off after
7353 > ; 45 days, but this can be overriden with commentable key.
7354 >
7355 > (= commentable-threshold* (* 60 24 45))
7356 >
7357 > (def comments-active (i)
7358 > (and (live&commentable i)
7359 > (live (superparent i))
7360 > (or (< (item-age i) commentable-threshold*)
7361 > (mem 'commentable i!keys))))
7362 >
7363 >
7364 > (= displayfn* (table))
7365 >
7366 > (= (displayfn* 'story) (fn (n i user here inlist)
7367 > (display-story n i user here)))
7368 >
7369 > (= (displayfn* 'comment) (fn (n i user here inlist)
7370 > (display-comment n i user here nil 0 nil inlist)))
7371 >
7372 > (= (displayfn* 'poll) (displayfn* 'story))
7373 >
7374 > (= (displayfn* 'pollopt) (fn (n i user here inlist)
7375 > (display-pollopt n i user here)))
7376 >
7377 > (def display-item (n i user here (o inlist))
7378 > ((displayfn* (i 'type)) n i user here inlist))
7379 >
7380 > (def superparent (i)
7381 > (aif i!parent (superparent:item it) i))
7382 >
7383 > (def display-item-text (s user)
7384 > (when (and (cansee user s)
7385 > (in s!type 'story 'poll)
7386 > (blank s!url)
7387 > (~blank s!text))
7388 > (spacerow 2)
7389 > (row "" s!text)))
7390 >
7391 >
7392 > ; Edit Item
7393 >
7394 > (def edit-url (i) (+ "edit?id=" i!id))
7395 >
7396 > (newsop edit (id)
7397 > (let i (safe-item id)
7398 > (if (and i
7399 > (cansee user i)
7400 > (editable-type i)
7401 > (or (news-type i) (admin user) (author user i)))
7402 > (edit-page user i)
7403 > (pr "No such item."))))
7404 >
7405 > (def editable-type (i) (fieldfn* i!type))
7406 >
7407 > (= fieldfn* (table))
7408 >
7409 > (= (fieldfn* 'story)
7410 > (fn (user s)
7411 > (with (a (admin user) e (editor user) x (canedit user s))
7412 > `((string1 title ,s!title t ,x)
7413 > (url url ,s!url t ,e)
7414 > (mdtext2 text ,s!text t ,x)
7415 > ,@(standard-item-fields s a e x)))))
7416 >
7417 > (= (fieldfn* 'comment)
7418 > (fn (user c)
7419 > (with (a (admin user) e (editor user) x (canedit user c))
7420 > `((mdtext text ,c!text t ,x)
7421 > ,@(standard-item-fields c a e x)))))
7422 >
7423 > (= (fieldfn* 'poll)
7424 > (fn (user p)
7425 > (with (a (admin user) e (editor user) x (canedit user p))
7426 > `((string1 title ,p!title t ,x)
7427 > (mdtext2 text ,p!text t ,x)
7428 > ,@(standard-item-fields p a e x)))))
7429 >
7430 > (= (fieldfn* 'pollopt)
7431 > (fn (user p)
7432 > (with (a (admin user) e (editor user) x (canedit user p))
7433 > `((string title ,p!title t ,x)
7434 > (url url ,p!url t ,x)
7435 > (mdtext2 text ,p!text t ,x)
7436 > ,@(standard-item-fields p a e x)))))
7437 >
7438 > (def standard-item-fields (i a e x)
7439 > `((int votes ,(len i!votes) ,a nil)
7440 > (int score ,i!score t ,a)
7441 > (int sockvotes ,i!sockvotes ,a ,a)
7442 > (yesno dead ,i!dead ,e ,e)
7443 > (yesno deleted ,i!deleted ,a ,a)
7444 > (sexpr flags ,i!flags ,a nil)
7445 > (sexpr keys ,i!keys ,a ,a)
7446 > (string ip ,i!ip ,e nil)))
7447 >
7448 > ; Should check valid-url etc here too. In fact make a fn that
7449 > ; does everything that has to happen after submitting a story,
7450 > ; and call it both there and here.
7451 >
7452 > (def edit-page (user i)
7453 > (let here (edit-url i)
7454 > (shortpage user nil nil "Edit" here
7455 > (tab (display-item nil i user here)
7456 > (display-item-text i user))
7457 > (br2)
7458 > (vars-form user
7459 > ((fieldfn* i!type) user i)
7460 > (fn (name val)
7461 > (unless (ignore-edit user i name val)
7462 > (when (and (is name 'dead) val (no i!dead))
7463 > (log-kill i user))
7464 > (= (i name) val)))
7465 > (fn () (if (admin user) (pushnew 'locked i!keys))
7466 > (save-item i)
7467 > (metastory&adjust-rank i)
7468 > (wipe (comment-cache* i!id))
7469 > (edit-page user i)))
7470 > (hook 'edit user i))))
7471 >
7472 > (def ignore-edit (user i name val)
7473 > (case name title (len> val title-limit*)
7474 > dead (and (mem 'nokill i!keys) (~admin user))))
7475 >
7476 >
7477 > ; Comment Submission
7478 >
7479 > (def comment-login-warning (parent whence (o text))
7480 > (login-page 'both "You have to be logged in to comment."
7481 > (fn (u ip)
7482 > (ensure-news-user u)
7483 > (newslog ip u 'comment-login)
7484 > (addcomment-page parent u whence text))))
7485 >
7486 > (def addcomment-page (parent user whence (o text) (o msg))
7487 > (minipage "Add Comment"
7488 > (pagemessage msg)
7489 > (tab
7490 > (let here (flink [addcomment-page parent (get-user _) whence text msg])
7491 > (display-item nil parent user here))
7492 > (spacerow 10)
7493 > (row "" (comment-form parent user whence text)))))
7494 >
7495 > (= noob-comment-msg* nil)
7496 >
7497 > ; Comment forms last for 30 min (- cache time)
7498 >
7499 > (def comment-form (parent user whence (o text))
7500 > (tarform 1800
7501 > (fn (req)
7502 > (when-umatch/r user req
7503 > (process-comment user parent (arg req "text") req!ip whence)))
7504 > (textarea "text" 6 60
7505 > (aif text (prn (unmarkdown it))))
7506 > (when (and noob-comment-msg* (noob user))
7507 > (br2)
7508 > (spanclass subtext (pr noob-comment-msg*)))
7509 > (br2)
7510 > (submit (if (acomment parent) "reply" "add comment"))))
7511 >
7512 > (= comment-threshold* -20)
7513 >
7514 > ; Have to remove #\returns because a form gives you back "a\r\nb"
7515 > ; instead of just "a\nb". Maybe should just remove returns from
7516 > ; the vals coming in from any form, e.g. in aform.
7517 >
7518 > (def process-comment (user parent text ip whence)
7519 > (if (no user)
7520 > (flink [comment-login-warning parent whence text])
7521 > (empty text)
7522 > (flink [addcomment-page parent (get-user _) whence text retry*])
7523 > (oversubmitting user ip 'comment)
7524 > (flink [msgpage user toofast*])
7525 > (atlet c (create-comment parent (md-from-form text) user ip)
7526 > (comment-ban-test user c ip text comment-kill* comment-ignore*)
7527 > (if (bad-user user) (kill c 'ignored/karma))
7528 > (submit-item user c)
7529 > whence)))
7530 >
7531 > (def bad-user (u)
7532 > (or (ignored u) (< (karma u) comment-threshold*)))
7533 >
7534 > (def create-comment (parent text user ip)
7535 > (newslog ip user 'comment (parent 'id))
7536 > (let c (inst 'item 'type 'comment 'id (new-item-id)
7537 > 'text text 'parent parent!id 'by user 'ip ip)
7538 > (save-item c)
7539 > (= (items* c!id) c)
7540 > (push c!id parent!kids)
7541 > (save-item parent)
7542 > (push c comments*)
7543 > c))
7544 >
7545 >
7546 > ; Comment Display
7547 >
7548 > (def display-comment-tree (c user whence (o indent 0) (o initialpar))
7549 > (when (cansee-descendant user c)
7550 > (display-1comment c user whence indent initialpar)
7551 > (display-subcomments c user whence (+ indent 1))))
7552 >
7553 > (def display-1comment (c user whence indent showpar)
7554 > (row (tab (display-comment nil c user whence t indent showpar showpar))))
7555 >
7556 > (def display-subcomments (c user whence (o indent 0))
7557 > (each k (sort (compare > frontpage-rank:item) c!kids)
7558 > (display-comment-tree (item k) user whence indent)))
7559 >
7560 > (def display-comment (n c user whence (o astree) (o indent 0)
7561 > (o showpar) (o showon))
7562 > (tr (display-item-number n)
7563 > (when astree (td (hspace (* indent 40))))
7564 > (tag (td valign 'top) (votelinks c user whence t))
7565 > (display-comment-body c user whence astree indent showpar showon)))
7566 >
7567 > ; Comment caching doesn't make generation of comments significantly
7568 > ; faster, but may speed up everything else by generating less garbage.
7569 >
7570 > ; It might solve the same problem more generally to make html code
7571 > ; more efficient.
7572 >
7573 > (= comment-cache* (table) comment-cache-timeout* (table) cc-window* 10000)
7574 >
7575 > (= comments-printed* 0 cc-hits* 0)
7576 >
7577 > (= comment-caching* t)
7578 >
7579 > ; Cache comments generated for nil user that are over an hour old.
7580 > ; Only try to cache most recent 10k items. But this window moves,
7581 > ; so if server is running a long time could have more than that in
7582 > ; cache. Probably should actively gc expired cache entries.
7583 >
7584 > (def display-comment-body (c user whence astree indent showpar showon)
7585 > (++ comments-printed*)
7586 > (if (and comment-caching*
7587 > astree (no showpar) (no showon)
7588 > (live c)
7589 > (nor (admin user) (editor user) (author user c))
7590 > (< (- maxid* c!id) cc-window*)
7591 > (> (- (seconds) c!time) 60)) ; was 3600
7592 > (pr (cached-comment-body c user whence indent))
7593 > (gen-comment-body c user whence astree indent showpar showon)))
7594 >
7595 > (def cached-comment-body (c user whence indent)
7596 > (or (and (> (or (comment-cache-timeout* c!id) 0) (seconds))
7597 > (awhen (comment-cache* c!id)
7598 > (++ cc-hits*)
7599 > it))
7600 > (= (comment-cache-timeout* c!id)
7601 > (cc-timeout c!time)
7602 > (comment-cache* c!id)
7603 > (tostring (gen-comment-body c user whence t indent nil nil)))))
7604 >
7605 > ; Cache for the remainder of the current minute, hour, or day.
7606 >
7607 > (def cc-timeout (t0)
7608 > (let age (- (seconds) t0)
7609 > (+ t0 (if (< age 3600)
7610 > (* (+ (trunc (/ age 60)) 1) 60)
7611 > (< age 86400)
7612 > (* (+ (trunc (/ age 3600)) 1) 3600)
7613 > (* (+ (trunc (/ age 86400)) 1) 86400)))))
7614 >
7615 > (def gen-comment-body (c user whence astree indent showpar showon)
7616 > (tag (td class 'default)
7617 > (let parent (and (or (no astree) showpar) (c 'parent))
7618 > (tag (div style "margin-top:2px; margin-bottom:-10px; ")
7619 > (spanclass comhead
7620 > (itemline c user)
7621 > (permalink c user)
7622 > (when parent
7623 > (when (cansee user c) (pr bar*))
7624 > (link "parent" (item-url ((item parent) 'id))))
7625 > (editlink c user)
7626 > (killlink c user whence)
7627 > (blastlink c user whence)
7628 > (deletelink c user whence)
7629 > ; a hack to check whence but otherwise need an arg just for this
7630 > (unless (or astree (is whence "newcomments"))
7631 > (flaglink c user whence))
7632 > (deadmark c user)
7633 > (when showon
7634 > (pr " | on: ")
7635 > (let s (superparent c)
7636 > (link (ellipsize s!title 50) (item-url s!id))))))
7637 > (when (or parent (cansee user c))
7638 > (br))
7639 > (spanclass comment
7640 > (if (~cansee user c) (pr (pseudo-text c))
7641 > (nor (live c) (author user c)) (spanclass dead (pr c!text))
7642 > (fontcolor (comment-color c)
7643 > (pr c!text))))
7644 > (when (and astree (cansee user c) (live c))
7645 > (para)
7646 > (tag (font size 1)
7647 > (if (and (~mem 'neutered c!keys)
7648 > (replyable c indent)
7649 > (comments-active c))
7650 > (underline (replylink c whence))
7651 > (fontcolor sand (pr "-----"))))))))
7652 >
7653 > ; For really deeply nested comments, caching could add another reply
7654 > ; delay, but that's ok.
7655 >
7656 > ; People could beat this by going to the link url or manually entering
7657 > ; the reply url, but deal with that if they do.
7658 >
7659 > (= reply-decay* 1.8) ; delays: (0 0 1 3 7 12 18 25 33 42 52 63)
7660 >
7661 > (def replyable (c indent)
7662 > (or (< indent 2)
7663 > (> (item-age c) (expt (- indent 1) reply-decay*))))
7664 >
7665 > (def replylink (i whence (o title 'reply))
7666 > (link title (+ "reply?id=" i!id "&whence=" (urlencode whence))))
7667 >
7668 > (newsop reply (id whence)
7669 > (with (i (safe-item id)
7670 > whence (or (only.urldecode whence) "news"))
7671 > (if (only.comments-active i)
7672 > (if user
7673 > (addcomment-page i user whence)
7674 > (login-page 'both "You have to be logged in to comment."
7675 > (fn (u ip)
7676 > (ensure-news-user u)
7677 > (newslog ip u 'comment-login)
7678 > (addcomment-page i u whence))))
7679 > (pr "No such item."))))
7680 >
7681 > (def comment-color (c)
7682 > (if (> c!score 0) black (grayrange c!score)))
7683 >
7684 > (defmemo grayrange (s)
7685 > (gray (min 230 (round (expt (* (+ (abs s) 2) 900) .6)))))
7686 >
7687 >
7688 > ; Threads
7689 >
7690 > (def threads-url (user) (+ "threads?id=" user))
7691 >
7692 > (newsop threads (id)
7693 > (if id
7694 > (threads-page user id)
7695 > (pr "No user specified.")))
7696 >
7697 > (def threads-page (user subject)
7698 > (if (profile subject)
7699 > (withs (title (+ subject "'s comments")
7700 > label (if (is user subject) "threads" title)
7701 > here (threads-url subject))
7702 > (longpage user (msec) nil label title here
7703 > (awhen (keep [and (cansee user _) (~subcomment _)]
7704 > (comments subject maxend*))
7705 > (display-threads user it label title here))))
7706 > (prn "No such user.")))
7707 >
7708 > (def display-threads (user comments label title whence
7709 > (o start 0) (o end threads-perpage*))
7710 > (tab
7711 > (each c (cut comments start end)
7712 > (display-comment-tree c user whence 0 t))
7713 > (when end
7714 > (let newend (+ end threads-perpage*)
7715 > (when (and (<= newend maxend*) (< end (len comments)))
7716 > (spacerow 10)
7717 > (row (tab (tr (td (hspace 0))
7718 > (td (hspace votewid*))
7719 > (tag (td class 'title)
7720 > (morelink display-threads
7721 > comments label title end newend))))))))))
7722 >
7723 > (def submissions (user (o limit))
7724 > (map item (firstn limit (uvar user submitted))))
7725 >
7726 > (def comments (user (o limit))
7727 > (map item (retrieve limit acomment:item (uvar user submitted))))
7728 >
7729 > (def subcomment (c)
7730 > (some [and (acomment _) (is _!by c!by) (no _!deleted)]
7731 > (ancestors c)))
7732 >
7733 > (def ancestors (i)
7734 > (accum a (trav i!parent a:item self:!parent:item)))
7735 >
7736 >
7737 > ; Submitted
7738 >
7739 > (def submitted-url (user) (+ "submitted?id=" user))
7740 >
7741 > (newsop submitted (id)
7742 > (if id
7743 > (submitted-page user id)
7744 > (pr "No user specified.")))
7745 >
7746 > (def submitted-page (user subject)
7747 > (if (profile subject)
7748 > (with (label (+ subject "'s submissions")
7749 > here (submitted-url subject))
7750 > (longpage user (msec) nil label label here
7751 > (if (or (no (ignored subject))
7752 > (is user subject)
7753 > (seesdead user))
7754 > (aif (keep [and (metastory _) (cansee user _)]
7755 > (submissions subject))
7756 > (display-items user it label label here 0 perpage* t)))))
7757 > (pr "No such user.")))
7758 >
7759 >
7760 > ; RSS
7761 >
7762 > (newsop rss () (rsspage nil))
7763 >
7764 > (newscache rsspage user 90
7765 > (rss-stories (retrieve perpage* live ranked-stories*)))
7766 >
7767 > (def rss-stories (stories)
7768 > (tag (rss version "2.0")
7769 > (tag channel
7770 > (tag title (pr this-site*))
7771 > (tag link (pr site-url*))
7772 > (tag description (pr site-desc*))
7773 > (each s stories
7774 > (tag item
7775 > (let comurl (+ site-url* (item-url s!id))
7776 > (tag title (pr (eschtml s!title)))
7777 > (tag link (pr (if (blank s!url) comurl (eschtml s!url))))
7778 > (tag comments (pr comurl))
7779 > (tag description
7780 > (cdata (link "Comments" comurl)))))))))
7781 >
7782 >
7783 > ; User Stats
7784 >
7785 > (newsop leaders () (leaderspage user))
7786 >
7787 > (= nleaders* 20)
7788 >
7789 > (newscache leaderspage user 1000
7790 > (longpage user (msec) nil "leaders" "Leaders" "leaders"
7791 > (sptab
7792 > (let i 0
7793 > (each u (firstn nleaders* (leading-users))
7794 > (tr (tdr:pr (++ i) ".")
7795 > (td (userlink user u nil))
7796 > (tdr:pr (karma u))
7797 > (when (admin user)
7798 > (tdr:prt (only.num (uvar u avg) 2 t t))))
7799 > (if (is i 10) (spacerow 30)))))))
7800 >
7801 > (= leader-threshold* 1) ; redefined later
7802 >
7803 > (def leading-users ()
7804 > (sort (compare > [karma _])
7805 > (users [and (> (karma _) leader-threshold*) (~admin _)])))
7806 >
7807 > (adop editors ()
7808 > (tab (each u (users [is (uvar _ auth) 1])
7809 > (row (userlink user u)))))
7810 >
7811 >
7812 > (= update-avg-threshold* 0) ; redefined later
7813 >
7814 > (defbg update-avg 45
7815 > (unless (or (empty profs*) (no stories*))
7816 > (update-avg (rand-user [and (only.> (car (uvar _ submitted))
7817 > (- maxid* initload*))
7818 > (len> (uvar _ submitted)
7819 > update-avg-threshold*)]))))
7820 >
7821 > (def update-avg (user)
7822 > (= (uvar user avg) (comment-score user))
7823 > (save-prof user))
7824 >
7825 > (def rand-user ((o test idfn))
7826 > (evtil (rand-key profs*) test))
7827 >
7828 > ; Ignore the most recent 5 comments since they may still be gaining votes.
7829 > ; Also ignore the highest-scoring comment, since possibly a fluff outlier.
7830 >
7831 > (def comment-score (user)
7832 > (aif (check (nthcdr 5 (comments user 50)) [len> _ 10])
7833 > (avg (cdr (sort > (map !score (rem !deleted it)))))
7834 > nil))
7835 >
7836 >
7837 > ; Comment Analysis
7838 >
7839 > ; Instead of a separate active op, should probably display this info
7840 > ; implicitly by e.g. changing color of commentlink or by showing the
7841 > ; no of comments since that user last looked.
7842 >
7843 > (newsop active () (active-page user))
7844 >
7845 > (newscache active-page user 600
7846 > (listpage user (msec) (actives user) "active" "Active Threads"))
7847 >
7848 > (def actives (user (o n maxend*) (o consider 2000))
7849 > (visible user (rank-stories n consider (memo active-rank))))
7850 >
7851 > (= active-threshold* 1500)
7852 >
7853 > (def active-rank (s)
7854 > (sum [max 0 (- active-threshold* (item-age _))]
7855 > (cdr (family s))))
7856 >
7857 > (def family (i) (cons i (mappend family:item i!kids)))
7858 >
7859 >
7860 > (newsop newcomments () (newcomments-page user))
7861 >
7862 > (newscache newcomments-page user 60
7863 > (listpage user (msec) (visible user (firstn maxend* comments*))
7864 > "comments" "New Comments" "newcomments" nil))
7865 >
7866 >
7867 > ; Doc
7868 >
7869 > (defop formatdoc req
7870 > (msgpage (get-user req) formatdoc* "Formatting Options"))
7871 >
7872 > (= formatdoc-url* "formatdoc")
7873 >
7874 > (= formatdoc*
7875 > "Blank lines separate paragraphs.
7876 > Text after a blank line that is indented by two or more spaces is
7877 > reproduced verbatim. (This is intended for code.)
7878 >
Text surrounded by asterisks is italicized, if the character after the
7879 > first asterisk isn't whitespace.
7880 >
Urls become links, except in the text field of a submission.Get back to work! ")
7909 > (para "Sorry, you can't see this page. Based on the anti-procrastination
7910 > parameters you set in your profile, you'll be able to use the site
7911 > again in " (plural m "minute") ".")
7912 > (para "(If you got this message after submitting something, don't worry,
7913 > the submission was processed.)")
7914 > (para "To change your anti-procrastination settings, go to your profile
7915 > by clicking on your username. If noprocrast is set to
7916 > yes , you'll be limited to sessions of maxvisit
7917 > minutes, with minaway minutes between them.")
7918 > (para)
7919 > (w/rlink whence (underline (pr "retry")))
7920 > ; (hspace 20)
7921 > ; (w/rlink (do (reset-procrast user) whence) (underline (pr "override")))
7922 > (br2)))
7923 >
7924 >
7925 > ; Reset PW
7926 >
7927 > (defopg resetpw req (resetpw-page (get-user req)))
7928 >
7929 > (def resetpw-page (user (o msg))
7930 > (minipage "Reset Password"
7931 > (if msg
7932 > (pr msg)
7933 > (blank (uvar user email))
7934 > (do (pr "Before you do this, please add your email address to your ")
7935 > (underlink "profile" (user-url user))
7936 > (pr ". Otherwise you could lose your account if you mistype
7937 > your new password.")))
7938 > (br2)
7939 > (uform user req (try-resetpw user (arg req "p"))
7940 > (single-input "New password: " 'p 20 "reset" t))))
7941 >
7942 > (def try-resetpw (user newpw)
7943 > (if (len< newpw 4)
7944 > (resetpw-page user "Passwords should be a least 4 characters long.
7945 > Please choose another.")
7946 > (do (set-pw user newpw)
7947 > (newspage user))))
7948 >
7949 >
7950 > ; Scrubrules
7951 >
7952 > (defopa scrubrules req
7953 > (scrub-page (get-user req) scrubrules*))
7954 >
7955 > ; If have other global alists, generalize an alist edit page.
7956 > ; Or better still generalize vars-form.
7957 >
7958 > (def scrub-page (user rules (o msg nil))
7959 > (minipage "Scrubrules"
7960 > (when msg (pr msg) (br2))
7961 > (uform user req
7962 > (with (froms (lines (arg req "from"))
7963 > tos (lines (arg req "to")))
7964 > (if (is (len froms) (len tos))
7965 > (do (todisk scrubrules* (map list froms tos))
7966 > (scrub-page user scrubrules* "Changes saved."))
7967 > (scrub-page user rules "To and from should be same length.")))
7968 > (pr "From: ")
7969 > (tag (textarea name 'from
7970 > cols (apply max 20 (map len (map car rules)))
7971 > rows (+ (len rules) 3))
7972 > (apply pr #\newline (intersperse #\newline (map car rules))))
7973 > (pr " To: ")
7974 > (tag (textarea name 'to
7975 > cols (apply max 20 (map len (map cadr rules)))
7976 > rows (+ (len rules) 3))
7977 > (apply pr #\newline (intersperse #\newline (map cadr rules))))
7978 > (br2)
7979 > (submit "update"))))
7980 >
7981 >
7982 > ; Abuse Analysis
7983 >
7984 > (adop badsites ()
7985 > (sptab
7986 > (row "Dead" "Days" "Site" "O" "K" "I" "Users")
7987 > (each (site deads) (with (banned (banned-site-items)
7988 > pairs (killedsites))
7989 > (+ pairs (map [list _ (banned _)]
7990 > (rem (fn (d)
7991 > (some [caris _ d] pairs))
7992 > (keys banned-sites*)))))
7993 > (let ban (car (banned-sites* site))
7994 > (tr (tdr (when deads
7995 > (onlink (len deads)
7996 > (listpage user (msec) deads
7997 > nil (+ "killed at " site) "badsites"))))
7998 > (tdr (when deads (pr (round (days-since ((car deads) 'time))))))
7999 > (td site)
8000 > (td (w/rlink (do (set-site-ban user site nil) "badsites")
8001 > (fontcolor (if ban gray.220 black) (pr "x"))))
8002 > (td (w/rlink (do (set-site-ban user site 'kill) "badsites")
8003 > (fontcolor (case ban kill darkred gray.220) (pr "x"))))
8004 > (td (w/rlink (do (set-site-ban user site 'ignore) "badsites")
8005 > (fontcolor (case ban ignore darkred gray.220) (pr "x"))))
8006 > (td (each u (dedup (map !by deads))
8007 > (userlink user u nil)
8008 > (pr " "))))))))
8009 >
8010 > (defcache killedsites 300
8011 > (let bads (table [each-loaded-item i
8012 > (awhen (and i!dead (sitename i!url))
8013 > (push i (_ it)))])
8014 > (with (acc nil deadcount (table))
8015 > (each (site items) bads
8016 > (let n (len items)
8017 > (when (> n 2)
8018 > (= (deadcount site) n)
8019 > (insort (compare > deadcount:car)
8020 > (list site (rev items))
8021 > acc))))
8022 > acc)))
8023 >
8024 > (defcache banned-site-items 300
8025 > (table [each-loaded-item i
8026 > (awhen (and i!dead (check (sitename i!url) banned-sites*))
8027 > (push i (_ it)))]))
8028 >
8029 > ; Would be nice to auto unban ips whose most recent submission is > n
8030 > ; days old, but hard to do because of lazy loading. Would have to keep
8031 > ; a table of most recent submission per ip, and only enforce bannnedness
8032 > ; if < n days ago.
8033 >
8034 > (adop badips ()
8035 > (withs ((bads goods) (badips)
8036 > (subs ips) (sorted-badips bads goods))
8037 > (sptab
8038 > (row "IP" "Days" "Dead" "Live" "Users")
8039 > (each ip ips
8040 > (tr (td (let banned (banned-ips* ip)
8041 > (w/rlink (do (set-ip-ban user ip (no banned))
8042 > "badips")
8043 > (fontcolor (if banned darkred) (pr ip)))))
8044 > (tdr (when (or (goods ip) (bads ip))
8045 > (pr (round (days-since
8046 > (max (aif (car (goods ip)) it!time 0)
8047 > (aif (car (bads ip)) it!time 0)))))))
8048 > (tdr (onlink (len (bads ip))
8049 > (listpage user (msec) (bads ip)
8050 > nil (+ "dead from " ip) "badips")))
8051 > (tdr (onlink (len (goods ip))
8052 > (listpage user (msec) (goods ip)
8053 > nil (+ "live from " ip) "badips")))
8054 > (td (each u (subs ip)
8055 > (userlink user u nil)
8056 > (pr " "))))))))
8057 >
8058 > (defcache badips 300
8059 > (with (bads (table) goods (table))
8060 > (each-loaded-item s
8061 > (if (and s!dead (commentable s))
8062 > (push s (bads s!ip))
8063 > (push s (goods s!ip))))
8064 > (each (k v) bads (zap rev (bads k)))
8065 > (each (k v) goods (zap rev (goods k)))
8066 > (list bads goods)))
8067 >
8068 > (def sorted-badips (bads goods)
8069 > (withs (ips (let ips (rem [len< (bads _) 2] (keys bads))
8070 > (+ ips (rem [mem _ ips] (keys banned-ips*))))
8071 > subs (table
8072 > [each ip ips
8073 > (= (_ ip) (dedup (map !by (+ (bads ip) (goods ip)))))]))
8074 > (list subs
8075 > (sort (compare > (memo [badness (subs _) (bads _) (goods _)]))
8076 > ips))))
8077 >
8078 > (def badness (subs bads goods)
8079 > (* (/ (len bads)
8080 > (max .9 (expt (len goods) 2))
8081 > (expt (+ (days-since (aif (car bads) it!time 0))
8082 > 1)
8083 > 2))
8084 > (if (len> subs 1) 20 1)))
8085 >
8086 >
8087 > (edop flagged ()
8088 > (display-selected-items user [retrieve maxend* flagged _] "flagged"))
8089 >
8090 > (def flagged (i)
8091 > (and (live i)
8092 > (~mem 'nokill i!keys)
8093 > (len> i!flags many-flags*)))
8094 >
8095 >
8096 > (edop killed ()
8097 > (display-selected-items user [retrieve maxend* !dead _] "killed"))
8098 >
8099 > (def display-selected-items (user f whence)
8100 > (display-items user (f stories*) nil nil whence)
8101 > (vspace 35)
8102 > (color-stripe textgray)
8103 > (vspace 35)
8104 > (display-items user (f comments*) nil nil whence))
8105 >
8106 >
8107 > ; Rather useless thus; should add more data.
8108 >
8109 > (adop badguys ()
8110 > (tab (each u (sort (compare > [uvar _ created])
8111 > (users [ignored _]))
8112 > (row (userlink user u nil)))))
8113 >
8114 > (adop badlogins () (logins-page bad-logins*))
8115 >
8116 > (adop goodlogins () (logins-page good-logins*))
8117 >
8118 > (def logins-page (source)
8119 > (sptab (each (time ip user) (firstn 100 (rev (qlist source)))
8120 > (row time ip user))))
8121 >
8122 >
8123 > ; Stats
8124 >
8125 > (adop optimes ()
8126 > (sptab
8127 > (tr (td "op") (tdr "avg") (tdr "med") (tdr "req") (tdr "total"))
8128 > (spacerow 10)
8129 > (each name (sort < newsop-names*)
8130 > (tr (td name)
8131 > (let ms (only.avg (qlist (optimes* name)))
8132 > (tdr:prt (only.round ms))
8133 > (tdr:prt (only.med (qlist (optimes* name))))
8134 > (let n (opcounts* name)
8135 > (tdr:prt n)
8136 > (tdr:prt (and n (round (/ (* n ms) 1000))))))))))
8137 >
8138 > (defop topcolors req
8139 > (minipage "Custom Colors"
8140 > (tab
8141 > (each c (dedup (map downcase (trues [uvar _ topcolor] (users))))
8142 > (tr (td c) (tdcolor (hex>color c) (hspace 30)))))))
8143 >
8144 >
8145 >