Context Navigation

source: project/release/4/awful/trunk/awful.scm @ 25886

Last change on this file since 25886 was 25886, checked in by Mario Domenech Goulart, 9 years ago
awful: don't check `current-effective-user-id' on windows
File size: 39.7 KB

Line
1	(module awful
2	(;; Parameters
3	awful-apps debug-file debug-db-query?
4	debug-db-query-prefix db-credentials ajax-library
5	enable-ajax ajax-namespace enable-session page-access-control
6	page-access-denied-message page-doctype page-css page-charset
7	login-page-path main-page-path app-root-path valid-password?
8	page-template ajax-invalid-session-message web-repl-access-control
9	web-repl-access-denied-message session-inspector-access-control
10	session-inspector-access-denied-message page-exception-message
11	http-request-variables db-connection page-javascript sid
12	enable-javascript-compression javascript-compressor debug-resources
13	enable-session-cookie session-cookie-name session-cookie-setter
14	awful-response-headers development-mode? enable-web-repl-fancy-editor
15	web-repl-fancy-editor-base-uri awful-listen awful-accept awful-backlog
16	awful-listener javascript-position
17
18	;; Procedures
19	++ concat include-javascript add-javascript debug debug-pp $session
20	$session-set! $ $db $db-row-obj sql-quote define-page undefine-page
21	define-session-page ajax ajax-link periodical-ajax login-form
22	define-login-trampoline enable-web-repl enable-session-inspector
23	awful-version load-apps reload-apps link form redirect-to
24	add-request-handler-hook! remove-request-handler-hook!
25
26	;; spiffy-request-vars wrapper
27	with-request-variables true-boolean-values as-boolean as-list
28	as-number as-alist as-vector as-hash-table as-string as-symbol
29	nonempty
30
31	;; Required by the awful server
32	add-resource! register-dispatcher register-root-dir-handler awful-start
33
34	;; Required by db-support eggs
35	db-enabled? db-inquirer db-connect db-disconnect sql-quoter db-make-row-obj
36
37	) ; end export list
38
39	(import scheme chicken data-structures utils extras ports srfi-69 files srfi-1)
40
41	;; Units
42	(use posix srfi-13 tcp)
43
44	;; Eggs
45	(use intarweb spiffy spiffy-request-vars html-tags html-utils uri-common
46	http-session json spiffy-cookies regex)
47
48	;;; Version
49	(define (awful-version) "0.33")
50
51
52	;;; Parameters
53
54	;; User-configurable parameters
55	(define awful-apps (make-parameter '()))
56	(define debug-file (make-parameter #f))
57	(define debug-db-query? (make-parameter #t))
58	(define debug-db-query-prefix (make-parameter ""))
59	(define db-credentials (make-parameter #f))
60	(define ajax-library (make-parameter "//ajax.googleapis.com/ajax/libs/jquery/1.7.1/jquery.min.js"))
61	(define enable-ajax (make-parameter #f))
62	(define ajax-namespace (make-parameter "ajax"))
63	(define enable-session (make-parameter #f))
64	(define page-access-control (make-parameter (lambda (path) #t)))
65	(define page-access-denied-message (make-parameter (lambda (path) (<h3> "Access denied."))))
66	(define page-doctype (make-parameter ""))
67	(define page-css (make-parameter #f))
68	(define page-charset (make-parameter #f))
69	(define login-page-path (make-parameter "/login")) ;; don't forget no-session: #t for this page
70	(define main-page-path (make-parameter "/"))
71	(define app-root-path (make-parameter "/"))
72	(define valid-password? (make-parameter (lambda (user password) #f)))
73	(define page-template (make-parameter html-page))
74	(define ajax-invalid-session-message (make-parameter "Invalid session."))
75	(define web-repl-access-control (make-parameter (lambda () #f)))
76	(define web-repl-access-denied-message (make-parameter (<h3> "Access denied.")))
77	(define session-inspector-access-control (make-parameter (lambda () #f)))
78	(define session-inspector-access-denied-message (make-parameter (<h3> "Access denied.")))
79	(define enable-javascript-compression (make-parameter #f))
80	(define javascript-compressor (make-parameter identity))
81	(define awful-response-headers (make-parameter #f))
82	(define development-mode? (make-parameter #f))
83	(define enable-web-repl-fancy-editor (make-parameter #t))
84	(define web-repl-fancy-editor-base-uri (make-parameter "http://parenteses.org/awful/codemirror"))
85	(define page-exception-message
86	(make-parameter
87	(lambda (exn)
88	(<h3> "An error has accurred while processing your request."))))
89	(define debug-resources (make-parameter #f)) ;; usually useful for awful development debugging
90	(define enable-session-cookie (make-parameter #t))
91	(define session-cookie-name (make-parameter "awful-cookie"))
92	(define session-cookie-setter (make-parameter
93	(lambda (sid)
94	(set-cookie! (session-cookie-name) sid))))
95	(define javascript-position (make-parameter 'top))
96
97	;; Parameters for internal use (but exported, since they are internally used by other eggs)
98	(define http-request-variables (make-parameter #f))
99	(define db-connection (make-parameter #f))
100	(define page-javascript (make-parameter ""))
101	(define sid (make-parameter #f))
102	(define db-enabled? (make-parameter #f))
103	(define awful-listen (make-parameter tcp-listen))
104	(define awful-accept (make-parameter tcp-accept))
105	(define awful-backlog (make-parameter 100))
106	(define awful-listener (make-parameter
107	(let ((listener #f))
108	(lambda ()
109	(unless listener
110	(set! listener
111	((awful-listen)
112	(server-port)
113	(awful-backlog)
114	(server-bind-address))))
115	listener))))
116
117	;; Parameters for internal use and not exported
118	(define %redirect (make-parameter #f))
119	(define %web-repl-path (make-parameter #f))
120	(define %session-inspector-path (make-parameter #f))
121	(define %error (make-parameter #f))
122
123	;; db-support parameters (set by awful-<db> eggs)
124	(define missing-db-msg "Database access is not enabled (see `enable-db').")
125	(define db-inquirer (make-parameter (lambda (query) (error '$db missing-db-msg))))
126	(define db-connect (make-parameter (lambda (credentials) (error 'db-connect missing-db-msg))))
127	(define db-disconnect (make-parameter (lambda (connection) (error 'db-disconnect missing-db-msg))))
128	(define sql-quoter (make-parameter (lambda args (error 'sql-quote missing-db-msg))))
129	(define db-make-row-obj (make-parameter (lambda (q) (error '$db-row-obj missing-db-msg))))
130
131
132	;;; Misc
133	(define ++ string-append)
134
135	(define (concat args #!optional (sep ""))
136	(string-intersperse (map ->string args) sep))
137
138	(define-syntax with-request-variables
139	(syntax-rules ()
140	((_ bindings body ...) (with-request-vars* $ bindings body ...))))
141
142	(define (string->symbol* str)
143	(if (string? str)
144	(string->symbol str)
145	str))
146
147	(define (load-apps apps)
148	(for-each load apps)
149	(when (development-mode?) (development-mode-actions)))
150
151	(define (reload-apps apps)
152	(reset-resources!)
153	(load-apps apps))
154
155	(define (define-reload-page)
156	;; Define a /reload page for reloading awful apps
157	(define-page "/reload"
158	(lambda ()
159	(reload-apps (awful-apps))
160	(++ (<p> "The following awful apps have been reloaded on "
161	(seconds->string (current-seconds)))
162	(itemize (map <code> (awful-apps)))))
163	no-ajax: #t
164	title: "Awful reloaded applications"))
165
166	(define (development-mode-actions)
167	(print "Awful is running in development mode.")
168	(debug-log (current-error-port))
169
170	;; Print the call chain, the error message and links to the
171	;; web-repl and session-inspector (if enabled)
172	(page-exception-message
173	(lambda (exn)
174	(++ (<pre> convert-to-entities?: #t
175	(with-output-to-string
176	(lambda ()
177	(print-call-chain)
178	(print-error-message exn))))
179	(<p> "[" (<a> href: (or (%web-repl-path) "/web-repl") "Web REPL") "]"
180	(if (enable-session)
181	(++ " [" (<a> href: (or (%session-inspector-path) "/session-inspector")
182	"Session inspector") "]")
183	"")))))
184
185	;; If web-repl has not been activated, activate it allowing access
186	;; to the localhost at least (`web-repl-access-control' can be
187	;; used to provide more permissive control)
188	(unless (%web-repl-path)
189	(let ((old-access-control (web-repl-access-control)))
190	(web-repl-access-control
191	(lambda ()
192	(or (old-access-control)
193	(equal? (remote-address) "127.0.0.1")))))
194	(enable-web-repl "/web-repl"))
195
196	;; If session-inspector has not been activated, and if
197	;; `enable-session' is #t, activate it allowing access to the
198	;; localhost at least (`session-inspector-access-control' can be
199	;; used to provide more permissive control)
200	(when (and (enable-session) (not (%session-inspector-path)))
201	(let ((old-access-control (session-inspector-access-control)))
202	(session-inspector-access-control
203	(lambda ()
204	(or (old-access-control)
205	(equal? (remote-address) "127.0.0.1"))))
206	(enable-session-inspector "/session-inspector")))
207
208	;; The reload page
209	(define-reload-page))
210
211	(define (awful-start thunk #!key dev-mode? port ip-address use-fancy-web-repl? privileged-code)
212	(enable-web-repl-fancy-editor use-fancy-web-repl?)
213	(when dev-mode? (development-mode? #t))
214	(when port (server-port port))
215	(when ip-address (server-bind-address ip-address))
216	;; if privileged-code is provided, it is loaded before switching
217	;; user/group
218	(when privileged-code (privileged-code))
219	(let ((listener ((awful-listener))))
220	(switch-user/group (spiffy-user) (spiffy-group))
221	(when (and (not (eq? (software-type) 'windows))
222	(zero? (current-effective-user-id)))
223	(print "WARNING: awful is running with administrator privileges (not recommended)"))
224	;; load apps
225	(thunk)
226	;; Check for invalid javascript positioning
227	(unless (memq (javascript-position) '(top bottom))
228	(error 'awful-start
229	"Invalid value for `javascript-position'. Valid ones are: `top' and `bottom'."))
230	(register-root-dir-handler)
231	(register-dispatcher)
232	(accept-loop listener (awful-accept))))
233
234	(define (get-sid #!optional force-read-sid)
235	(and (or (enable-session) force-read-sid)
236	(if (enable-session-cookie)
237	(or (read-cookie (session-cookie-name)) ($ 'sid))
238	($ 'sid))))
239
240	(define (redirect-to new-uri)
241	;; Just set the `%redirect' internal parameter, so `run-resource' is
242	;; able to know where to redirect.
243	(%redirect new-uri)
244	"")
245
246
247	;;; Javascript
248	(define (include-javascript . files)
249	(string-intersperse
250	(map (lambda (file)
251	(<script> type: "text/javascript" src: file))
252	files)))
253
254	(define (add-javascript . code)
255	(page-javascript (++ (page-javascript) (concat code))))
256
257	(define (maybe-compress-javascript js no-javascript-compression)
258	(if (and (enable-javascript-compression)
259	(javascript-compressor)
260	(not no-javascript-compression))
261	(string-trim-both ((javascript-compressor) js))
262	js))
263
264
265	;;; Debugging
266	(define (debug . args)
267	(when (debug-file)
268	(with-output-to-file (debug-file)
269	(lambda ()
270	(print (concat args)))
271	append:)))
272
273	(define (debug-pp arg)
274	(when (debug-file)
275	(with-output-to-file (debug-file) (cut pp arg) append:)))
276
277
278	;;; Session access
279	(define ($session var #!optional default)
280	(session-ref (sid) (string->symbol* var) default))
281
282	(define ($session-set! var #!optional val)
283	(if (list? var)
284	(for-each (lambda (var/val)
285	(session-set! (sid) (string->symbol* (car var/val)) (cdr var/val)))
286	var)
287	(session-set! (sid) (string->symbol* var) val)))
288
289	(define (awful-refresh-session!)
290	(when (and (enable-session) (session-valid? (sid)))
291	(session-refresh! (sid))))
292
293
294	;;; Session-aware procedures for HTML code generation
295	(define (link url text . rest)
296	(let ((pass-sid? (and (not (enable-session-cookie))
297	(sid)
298	(session-valid? (sid))
299	(not (get-keyword no-session: rest))))
300	(arguments (or (get-keyword arguments: rest) '()))
301	(separator (or (get-keyword separator: rest) ";&")))
302	(apply <a>
303	(append
304	(list href: (if url
305	(++ url
306	(if (or pass-sid? (not (null? arguments)))
307	(++ "?"
308	(form-urlencode
309	(append arguments
310	(if pass-sid?
311	`((sid . ,(sid)))
312	'()))
313	separator: separator))
314	""))
315	"#"))
316	rest
317	(list text)))))
318
319	(define (form contents . rest)
320	(let ((pass-sid? (and (not (enable-session-cookie))
321	(sid)
322	(session-valid? (sid))
323	(not (get-keyword no-session: rest)))))
324	(apply <form>
325	(append rest
326	(list
327	(++ (if pass-sid?
328	(hidden-input 'sid (sid))
329	"")
330	contents))))))
331
332
333	;;; HTTP request variables access
334	(define ($ var #!optional default/converter)
335	(unless (http-request-variables)
336	(http-request-variables (request-vars)))
337	((http-request-variables) var default/converter))
338
339
340	;;; DB access
341	(define ($db q #!key default values)
342	(unless (db-enabled?)
343	(error '$db "Database access doesn't seem to be enabled. Did you call `(enable-db)'?"))
344	(debug-query q)
345	((db-inquirer) q default: default values: values))
346
347	(define (debug-query q)
348	(when (and (debug-file) (debug-db-query?))
349	(debug (++ (debug-db-query-prefix) q))))
350
351	(define ($db-row-obj q)
352	(debug-query q)
353	((db-make-row-obj) q))
354
355	(define (sql-quote . data)
356	((sql-quoter) data))
357
358
359	;;; Parameters reseting
360	(define (reset-per-request-parameters) ;; to cope with spiffy's thread reuse
361	(http-request-variables #f)
362	(awful-response-headers #f)
363	(db-connection #f)
364	(sid #f)
365	(%redirect #f)
366	(%error #f))
367
368
369	;;; Request handling hooks
370	(define request-handler-hooks '())
371
372	(define (add-request-handler-hook! name proc)
373	(set! request-handler-hooks
374	(cons (cons name proc) request-handler-hooks)))
375
376	(define (remove-request-handler-hook! name)
377	(set! request-handler-hooks
378	(alist-delete! name request-handler-hooks)))
379
380	;;; Resources
381	(root-path (current-directory))
382
383	(define resources (make-hash-table equal?))
384
385	(define (register-dispatcher)
386	(handle-not-found
387	(let ((old-handler (handle-not-found)))
388	(lambda (_)
389	(let* ((path-list (uri-path (request-uri (current-request))))
390	(method (request-method (current-request)))
391	(dir? (equal? (last path-list) ""))
392	(path (if (null? (cdr path-list))
393	(car path-list)
394	(++ "/" (concat (cdr path-list) "/"))))
395	(proc (resource-ref path (root-path) method)))
396	(if proc
397	(run-resource proc path)
398	(if dir? ;; try to find a procedure with the trailing slash removed
399	(let ((proc (resource-ref (string-chomp path "/") (root-path) method)))
400	(if proc
401	(run-resource proc path)
402	(old-handler _)))
403	(old-handler _))))))))
404
405	(define (run-resource proc path)
406	(reset-per-request-parameters)
407	(let ((handler
408	(lambda (path proc)
409	(let ((out (->string (proc path))))
410	(if (%error)
411	(send-response code: 500
412	reason: "Internal server error"
413	body: ((page-template) ((page-exception-message) (%error)))
414	headers: '((content-type text/html)))
415	(if (%redirect) ;; redirection
416	(let ((new-uri (if (string? (%redirect))
417	(uri-reference (%redirect))
418	(%redirect))))
419	(with-headers `((location ,new-uri))
420	(lambda ()
421	(send-status 302 "Found"))))
422	(with-headers (append
423	(or (awful-response-headers)
424	`((content-type text/html)))
425	(or (and-let* ((headers (awful-response-headers))
426	(content-length (alist-ref 'content-length headers)))
427	(list (cons 'content-length content-length)))
428	`((content-length ,(string-length out)))))
429	(lambda ()
430	(write-logged-response)
431	(unless (eq? 'HEAD (request-method (current-request)))
432	(display out (response-port (current-response))))))))))))
433	(call/cc (lambda (continue)
434	(for-each (lambda (hook)
435	((cdr hook) path
436	(lambda ()
437	(handler path proc)
438	(continue #f))))
439	request-handler-hooks)
440	(handler path proc)))))
441
442	(define (resource-ref path vhost-root-path method)
443	(when (debug-resources)
444	(debug-pp (hash-table->alist resources)))
445	(if (list? method)
446	(let loop ((methods '(POST GET PUT DELETE HEAD)))
447	(if (null? methods)
448	#f
449	(let ((method (car methods)))
450	(or (hash-table-ref/default resources
451	(list path vhost-root-path method)
452	#f)
453	(resource-match path vhost-root-path method)
454	(loop (cdr methods))))))
455	(or (hash-table-ref/default resources (list path vhost-root-path method) #f)
456	(resource-match path vhost-root-path method))))
457
458	(define (resource-match path vhost-root-path method)
459	(let loop ((resources (hash-table->alist resources)))
460	(if (null? resources)
461	#f
462	(let* ((current-resource (car resources))
463	(current-path (caar current-resource))
464	(current-vhost (cadar current-resource))
465	(current-method (caddar current-resource))
466	(current-proc (cdr current-resource)))
467	(if (and (regexp? current-path)
468	(equal? current-vhost vhost-root-path)
469	(eq? current-method method)
470	(string-match current-path path))
471	current-proc
472	(loop (cdr resources)))))))
473
474	(define (add-resource! path vhost-root-path proc method)
475	(let ((methods (if (list? method) method (list method))))
476	(for-each
477	(lambda (method)
478	(let ((upcase-method
479	(string->symbol (string-upcase (symbol->string method)))))
480	(hash-table-set! resources (list path vhost-root-path upcase-method) proc)))
481	methods)))
482
483	(define (reset-resources!)
484	(set! resources (make-hash-table equal?)))
485
486	;;; Root dir
487	(define (register-root-dir-handler)
488	(handle-directory
489	(let ((old-handler (handle-directory)))
490	(lambda (path)
491	(cond ((resource-ref path (root-path) (request-method (current-request)))
492	=> (cut run-resource <> path))
493	(else (old-handler path)))))))
494
495	;;; Pages
496	(define (undefine-page path #!key vhost-root-path (method 'GET))
497	(hash-table-delete! resources (list path (or vhost-root-path (root-path)) method)))
498
499	(define (include-page-javascript ajax? no-javascript-compression)
500	(if ajax?
501	(<script> type: "text/javascript"
502	(maybe-compress-javascript
503	(++ "$(document).ready(function(){"
504	(page-javascript) "});")
505	no-javascript-compression))
506	(if (string-null? (page-javascript))
507	""
508	(<script> type: "text/javascript"
509	(maybe-compress-javascript
510	(page-javascript)
511	no-javascript-compression)))))
512
513	(define (page-path path #!optional namespace)
514	(cond ((regexp? path) path)
515	((equal? path "/") "/")
516	(else
517	(string-chomp
518	(make-pathname (cons (app-root-path)
519	(if namespace
520	(list namespace)
521	'()))
522	path)
523	"/"))))
524
525	(define (define-page path contents #!key css title doctype headers charset no-ajax
526	no-template no-session no-db vhost-root-path no-javascript-compression
527	use-ajax (method 'GET)
528	use-session) ;; for define-session-page
529	(##sys#check-closure contents 'define-page)
530	(let ((path (page-path path)))
531	(add-resource!
532	path
533	(or vhost-root-path (root-path))
534	(lambda (#!optional given-path)
535	(sid (get-sid use-session))
536	(when (and (db-credentials) (db-enabled?) (not no-db))
537	(db-connection ((db-connect) (db-credentials))))
538	(page-javascript "")
539	(awful-refresh-session!)
540	(let ((out
541	(if (or (not (enable-session))
542	no-session
543	use-session
544	(and (enable-session) (session-valid? (sid))))
545	(if ((page-access-control) (or given-path path))
546	(begin
547	(when use-session
548	(if (session-valid? (sid))
549	(awful-refresh-session!)
550	(begin
551	(sid (session-create))
552	((session-cookie-setter) (sid)))))
553	(let* ((ajax? (cond (no-ajax #f)
554	((not (ajax-library)) #f)
555	((and (ajax-library) use-ajax) #t)
556	((enable-ajax) #t)
557	(else #f)))
558	(contents
559	(handle-exceptions exn
560	(begin
561	(%error exn)
562	(debug (with-output-to-string
563	(lambda ()
564	(print-call-chain)
565	(print-error-message exn))))
566	((page-exception-message) exn))
567	(++ (if (regexp? path)
568	(contents given-path)
569	(contents))
570	(if (eq? (javascript-position) 'bottom)
571	(include-page-javascript ajax? no-javascript-compression)
572	"")))))
573	(if (%redirect)
574	#f ;; no need to do anything. Let `run-resource' perform the redirection
575	(if no-template
576	contents
577	((page-template)
578	contents
579	css: (or css (page-css))
580	title: title
581	doctype: (or doctype (page-doctype))
582	headers: (++ (if ajax?
583	(<script> type: "text/javascript" src: (ajax-library))
584	"")
585	(or headers "")
586	(if (eq? (javascript-position) 'top)
587	(include-page-javascript ajax? no-javascript-compression)
588	""))
589	charset: (or charset (page-charset)))))))
590	((page-template) ((page-access-denied-message) (or given-path path))))
591	((page-template)
592	""
593	headers: (<meta> http-equiv: "refresh"
594	content: (++ "0;url=" (login-page-path)
595	"?reason=invalid-session&attempted-path=" (or given-path path)
596	"&user=" ($ 'user "")
597	(if (and (not (enable-session-cookie)) ($ 'sid))
598	(++ "&sid=" ($ 'sid))
599	"")))))))
600	(when (and (db-connection) (db-enabled?) (not no-db)) ((db-disconnect) (db-connection)))
601	out))
602	method))
603	path)
604
605	(define (define-session-page path contents . rest)
606	;; `rest' are same keyword params as for `define-page' (except `no-session', obviously)
607	(apply define-page (append (list path contents) (list use-session: #t) rest)))
608
609
610	;;; Ajax
611	(define (ajax path id event proc #!key (action 'html) (method 'POST) (arguments '())
612	target success no-session no-db no-page-javascript vhost-root-path
613	live content-type prelude update-targets (cache 'not-set) error-handler)
614	(let ((path (page-path path (ajax-namespace))))
615	(add-resource! path
616	(or vhost-root-path (root-path))
617	(lambda (#!optional given-path)
618	(sid (get-sid 'force))
619	(when update-targets
620	(awful-response-headers '((content-type "application/json"))))
621	(if (or (not (enable-session))
622	no-session
623	(and (enable-session) (session-valid? (sid))))
624	(if ((page-access-control) path)
625	(begin
626	(when (and (db-credentials) (db-enabled?) (not no-db))
627	(db-connection ((db-connect) (db-credentials))))
628	(awful-refresh-session!)
629	(let ((out (if update-targets
630	(with-output-to-string
631	(lambda ()
632	(json-write (list->vector (proc)))))
633	(proc))))
634	(when (and (db-credentials) (db-enabled?) (not no-db))
635	((db-disconnect) (db-connection)))
636	out))
637	((page-access-denied-message) path))
638	(ajax-invalid-session-message)))
639	method)
640	(let* ((arguments (if (and (sid) (session-valid? (sid)))
641	(cons `(sid . ,(++ "'" (sid) "'")) arguments)
642	arguments))
643	(js-code
644	(++ (if (and id event)
645	(let ((events (concat (if (list? event) event (list event)) " "))
646	(binder (if live "live" "bind")))
647	(++ "$('" (if (symbol? id)
648	(conc "#" id)
649	id)
650	"')." binder "('" events "',"))
651	"")
652	(++ "function(event){"
653	(or prelude "")
654	"$.ajax({type:'" (->string method) "',"
655	"url:'" path "',"
656	(if content-type
657	(conc "contentType: '" content-type "',")
658	"")
659	"success:function(response){"
660	(or success
661	(cond (update-targets
662	"$.each(response, function(id, html) { $('#' + id).html(html);});")
663	(target
664	(++ "$('#" target "')." (->string action) "(response);"))
665	(else "return;")))
666	"},"
667	(if update-targets
668	"dataType: 'json',"
669	"")
670	(if (eq? cache 'not-set)
671	""
672	(if cache
673	"cache:true,"
674	"cache:false,"))
675	(if error-handler
676	(++ "error:" error-handler ",")
677	"")
678	(++ "data:{"
679	(string-intersperse
680	(map (lambda (var/val)
681	(conc "'" (car var/val) "':" (cdr var/val)))
682	arguments)
683	",") "}")
684	"})}")
685	(if (and id event)
686	");\n"
687	""))))
688	(unless no-page-javascript (add-javascript js-code))
689	js-code)))
690
691	(define (periodical-ajax path interval proc #!key target (action 'html) (method 'POST)
692	(arguments '()) success no-session no-db vhost-root-path live
693	content-type prelude update-targets cache error-handler)
694	(add-javascript
695	(++ "setInterval("
696	(ajax path #f #f proc
697	target: target
698	action: action
699	method: method
700	arguments: arguments
701	success: success
702	no-session: no-session
703	no-db: no-db
704	vhost-root-path: vhost-root-path
705	live: live
706	content-type: content-type
707	prelude: prelude
708	update-targets: update-targets
709	error-handler: error-handler
710	cache: cache
711	no-page-javascript: #t)
712	", " (->string interval) ");\n")))
713
714	(define (ajax-link path id text proc #!key target (action 'html) (method 'POST) (arguments '())
715	success no-session no-db (event 'click) vhost-root-path live class
716	hreflang type rel rev charset coords shape accesskey tabindex a-target
717	content-type prelude update-targets error-handler cache)
718	(ajax path id event proc
719	target: target
720	action: action
721	method: method
722	arguments: arguments
723	success: success
724	no-session: no-session
725	vhost-root-path: vhost-root-path
726	live: live
727	content-type: content-type
728	prelude: prelude
729	update-targets: update-targets
730	error-handler: error-handler
731	cache: cache
732	no-db: no-db)
733	(<a> href: "#"
734	id: id
735	class: class
736	hreflang: hreflang
737	type: type
738	rel: rel
739	rev: rev
740	charset: charset
741	coords: coords
742	shape: shape
743	accesskey: accesskey
744	tabindex: tabindex
745	target: a-target
746	text))
747
748
749	;;; Login form
750	(define (login-form #!key (user-label "User: ")
751	(password-label "Password: ")
752	(submit-label "Submit")
753	(trampoline-path "/login-trampoline")
754	(refill-user #t))
755	(let ((attempted-path ($ 'attempted-path))
756	(user ($ 'user)))
757	(<form> action: trampoline-path method: "post"
758	(if attempted-path
759	(hidden-input 'attempted-path attempted-path)
760	"")
761	(<span> id: "user-container"
762	(<label> id: "user-label" for: "user" user-label)
763	(<input> type: "text" id: "user" name: "user" value: (and refill-user user)))
764	(<span> id: "password-container"
765	(<label> id: "password-label" for: "password" password-label)
766	(<input> type: "password" id: "password" name: "password"))
767	(<input> type: "submit" id: "login-submit" value: submit-label))))
768
769
770	;;; Login trampoline (for redirection)
771	(define (define-login-trampoline path #!key vhost-root-path hook)
772	(define-page path
773	(lambda ()
774	(let* ((user ($ 'user))
775	(password ($ 'password))
776	(attempted-path ($ 'attempted-path))
777	(password-valid? ((valid-password?) user password))
778	(new-sid (and password-valid? (session-create))))
779	(sid new-sid)
780	(when (enable-session-cookie)
781	((session-cookie-setter) new-sid))
782	(when hook (hook user))
783	(html-page
784	""
785	headers: (<meta> http-equiv: "refresh"
786	content: (++ "0;url="
787	(if new-sid
788	(++ (or attempted-path (main-page-path))
789	"?user=" user
790	(if (enable-session-cookie)
791	""
792	(++ "&sid=" new-sid)))
793	(++ (login-page-path) "?reason=invalid-password&user=" user)))))))
794	method: 'POST
795	vhost-root-path: vhost-root-path
796	no-session: #t
797	no-template: #t))
798
799
800	;;; Web repl
801	(define (enable-web-repl path #!key css (title "Awful Web REPL") headers)
802	(unless (development-mode?) (%web-repl-path path))
803	(define-page path
804	(lambda ()
805	(if ((web-repl-access-control))
806	(let ((web-eval
807	(lambda ()
808	(<pre> convert-to-entities?: #t
809	(with-output-to-string
810	(lambda ()
811	(pp (handle-exceptions
812	exn
813	(begin
814	(print-error-message exn)
815	(print-call-chain))
816	(eval `(begin
817	,@(with-input-from-string ($ 'code "")
818	read-file)))))))))))
819	(page-javascript
820	(++ "$('#clear').click(function(){"
821	(if (enable-web-repl-fancy-editor)
822	"editor.setCode('');"
823	"$('#prompt').val('');")
824	"});"))
825
826	(ajax (++ path "-eval") 'eval 'click web-eval
827	target: "result"
828	arguments: `((code . ,(if (enable-web-repl-fancy-editor)
829	"editor.getCode()"
830	"$('#prompt').val()"))))
831
832	(when (enable-web-repl-fancy-editor)
833	(ajax (++ path "-eval") 'eval-region 'click web-eval
834	target: "result"
835	arguments: `((code . "editor.selection()"))))
836
837	(++ (<h1> title)
838	(<h2> "Input area")
839	(let ((prompt (<textarea> id: "prompt" name: "prompt" rows: "10" cols: "90")))
840	(if (enable-web-repl-fancy-editor)
841	(<div> class: "border" prompt)
842	prompt))
843	(itemize
844	(map (lambda (item)
845	(<button> id: (car item) (cdr item)))
846	(append '(("eval" . "Eval"))
847	(if (enable-web-repl-fancy-editor)
848	'(("eval-region" . "Eval region"))
849	'())
850	'(("clear" . "Clear"))))
851	list-id: "button-bar")
852	(<h2> "Output area")
853	(<div> id: "result")
854	(if (enable-web-repl-fancy-editor)
855	(<script> type: "text/javascript" "
856	function addClass(element, className) {
857	if (!editor.win.hasClass(element, className)) {
858	element.className = ((element.className.split(' ')).concat([className])).join(' ');}}
859
860	function removeClass(element, className) {
861	if (editor.win.hasClass(element, className)) {
862	var classes = element.className.split(' ');
863	for (var i = classes.length - 1 ; i >= 0; i--) {
864	if (classes[i] === className) {
865	classes.splice(i, 1)}}
866	element.className = classes.join(' ');}}
867
868	var textarea = document.getElementById('prompt');
869	var editor = new CodeMirror(CodeMirror.replace(textarea), {
870	height: '250px',
871	width: '600px',
872	content: textarea.value,
873	parserfile: ['" (web-repl-fancy-editor-base-uri) "/tokenizescheme.js',
874	'" (web-repl-fancy-editor-base-uri) "/parsescheme.js'],
875	stylesheet: '" (web-repl-fancy-editor-base-uri) "/schemecolors.css',
876	autoMatchParens: true,
877	path: '" (web-repl-fancy-editor-base-uri) "/',
878	disableSpellcheck: true,
879	markParen: function(span, good) {addClass(span, good ? 'good-matching-paren' : 'bad-matching-paren');},
880	unmarkParen: function(span) {removeClass(span, 'good-matching-paren'); removeClass(span, 'bad-matching-paren');}
881	});")
882	"")))
883	(web-repl-access-denied-message)))
884	headers: (++ (if (enable-web-repl-fancy-editor)
885	(include-javascript (make-pathname (web-repl-fancy-editor-base-uri) "codemirror.js")
886	(make-pathname (web-repl-fancy-editor-base-uri) "mirrorframe.js"))
887	"")
888	(let ((builtin-css (if css
889	#f
890	(<style> type: "text/css"
891	"h1 { font-size: 18pt; background-color: #898E79; width: 590px; color: white; padding: 5px;}
892	h2 { font-size: 14pt; background-color: #898E79; width: 590px; color: white; padding: 5px;}
893	ul#button-bar { margin-left: 0; padding-left: 0; }
894	#button-bar li {display: inline; list-style-type: none; padding-right: 10px; }"
895	(if (enable-web-repl-fancy-editor)
896	"div.border { border: 1px solid black; width: 600px;}"
897	"#prompt { width: 600px; }")
898	"#result { border: 1px solid #333; padding: 5px; width: 590px; }"))))
899	(if headers
900	(++ (or builtin-css "") headers)
901	builtin-css)))
902	use-ajax: #t
903	title: title
904	css: css))
905
906
907	;;; Session inspector
908	(define (enable-session-inspector path #!key css (title "Awful session inspector") headers)
909	(unless (development-mode?) (%session-inspector-path path))
910	(define-page path
911	(lambda ()
912	(parameterize ((enable-session #t))
913	(if ((session-inspector-access-control))
914	(let ((bindings (session-bindings (sid))))
915	(++ (<h1> title)
916	(if (null? bindings)
917	(<p> "Session for sid " (sid) " is empty")
918	(++ (<p> "Session for " (sid))
919	(tabularize
920	(map (lambda (binding)
921	(let ((var (car binding))
922	(val (with-output-to-string
923	(lambda ()
924	(pp (cdr binding))))))
925	(list (<span> class: "session-inspector-var" var)
926	(<pre> convert-to-entities?: #t
927	class: "session-inspector-value"
928	val))))
929	bindings)
930	header: '("Variables" "Values")
931	table-id: "session-inspector-table")))))
932	(session-inspector-access-denied-message))))
933	headers: (let ((builtin-css (if css
934	#f
935	(<style> type: "text/css"
936	"h1 { font-size: 16pt; background-color: #898E79; width: 590px; color: white; padding: 5px;}
937	.session-inspector-value { margin: 2px;}
938	.session-inspector-var { margin: 0px; }
939	#session-inspector-table { margin: 0px; width: 600px;}
940	#session-inspector-table tr td, th { padding-left: 10px; border: 1px solid #333; vertical-align: middle; }"))))
941	(if headers
942	(++ (or builtin-css "") headers)
943	builtin-css))
944	title: title
945	css: css))
946
947	) ; end module

Note: See TracBrowser for help on using the repository browser.

Download in other formats: