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

Last change on this file since 26596 was 26596, checked in by Mario Domenech Goulart, 8 years ago

awful: special case for resource handlers which yield procedures. In those cases, awful won't do anything besides calling the returned procedure (not even set headers). That can be useful for calling things like `send-static-file' from resource handlers, so awful won't try to send anything else.

File size: 40.4 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.34")
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        (alist-update! 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 ((resp (proc path)))
410             (if (procedure? resp)
411                 (let ((out (->string resp)))
412                   (if (%error)
413                       (send-response code: 500
414                                      reason: "Internal server error"
415                                      body: ((page-template) ((page-exception-message) (%error)))
416                                      headers: '((content-type text/html)))
417                       (if (%redirect) ;; redirection
418                           (let ((new-uri (if (string? (%redirect))
419                                              (uri-reference (%redirect))
420                                              (%redirect))))
421                             (with-headers `((location ,new-uri))
422                                           (lambda ()
423                                             (send-status 302 "Found"))))
424                           (with-headers (append
425                                          (or (awful-response-headers)
426                                              `((content-type text/html)))
427                                          (or (and-let* ((headers (awful-response-headers))
428                                                         (content-length (alist-ref 'content-length headers)))
429                                                (list (cons 'content-length content-length)))
430                                              `((content-length ,(string-length out)))))
431                                         (lambda ()
432                                           (write-logged-response)
433                                           (unless (eq? 'HEAD (request-method (current-request)))
434                                             (display out (response-port (current-response))))))))))))))
435    (call/cc (lambda (continue)
436               (for-each (lambda (hook)
437                           ((cdr hook) path
438                                       (lambda ()
439                                         (handler path proc)
440                                         (continue #f))))
441                         *request-handler-hooks*)
442               (handler path proc)))))
443
444(define (resource-ref path vhost-root-path method)
445  (when (debug-resources)
446    (debug-pp (hash-table->alist *resources*)))
447  (if (list? method)
448      (let loop ((methods '(POST GET PUT DELETE HEAD)))
449        (if (null? methods)
450            #f
451            (let ((method (car methods)))
452              (or (hash-table-ref/default *resources*
453                                          (list path vhost-root-path method)
454                                          #f)
455                  (resource-match path vhost-root-path method)
456                  (loop (cdr methods))))))
457      (or (hash-table-ref/default *resources* (list path vhost-root-path method) #f)
458          (resource-match path vhost-root-path method))))
459
460(define (resource-match path vhost-root-path method)
461  (let loop ((resources (hash-table->alist *resources*)))
462    (if (null? resources)
463        #f
464        (let* ((current-resource (car resources))
465               (current-path (caar current-resource))
466               (current-vhost (cadar current-resource))
467               (current-method (caddar current-resource))
468               (current-proc (cdr current-resource)))
469          (if (and (regexp? current-path)
470                   (equal? current-vhost vhost-root-path)
471                   (eq? current-method method)
472                   (string-match current-path path))
473              current-proc
474              (loop (cdr resources)))))))
475
476(define (add-resource! path vhost-root-path proc method)
477  (let ((methods (if (list? method) method (list method))))
478    (for-each
479     (lambda (method)
480       (let ((upcase-method
481              (string->symbol (string-upcase (symbol->string method)))))
482         (hash-table-set! *resources* (list path vhost-root-path upcase-method) proc)))
483     methods)))
484
485(define (reset-resources!)
486  (set! *resources* (make-hash-table equal?)))
487
488;;; Root dir
489(define (register-root-dir-handler)
490  (handle-directory
491   (let ((old-handler (handle-directory)))
492     (lambda (path)
493       (cond ((resource-ref path (root-path) (request-method (current-request)))
494              => (cut run-resource <> path))
495             (else (old-handler path)))))))
496
497;;; Pages
498(define (undefine-page path #!key vhost-root-path (method 'GET))
499  (hash-table-delete! *resources* (list path (or vhost-root-path (root-path)) method)))
500
501(define (include-page-javascript ajax? no-javascript-compression)
502  (if ajax?
503      (<script> type: "text/javascript"
504                (maybe-compress-javascript
505                 (++ "$(document).ready(function(){"
506                     (page-javascript) "});")
507                 no-javascript-compression))
508      (if (string-null? (page-javascript))
509          ""
510          (<script> type: "text/javascript"
511                    (maybe-compress-javascript
512                     (page-javascript)
513                     no-javascript-compression)))))
514
515(define (page-path path #!optional namespace)
516  (cond ((regexp? path) path)
517        ((equal? path "/") "/")
518        (else
519         (string-chomp
520          (make-pathname (cons (app-root-path)
521                               (if namespace
522                                   (list namespace)
523                                   '()))
524                         path)
525          "/"))))
526
527(define (define-page path contents #!key css title doctype headers charset no-ajax
528                     no-template no-session no-db vhost-root-path no-javascript-compression
529                     use-ajax (method 'GET)
530                     use-session) ;; for define-session-page
531  (##sys#check-closure contents 'define-page)
532  (let ((path (page-path path)))
533    (add-resource!
534     path
535     (or vhost-root-path (root-path))
536     (lambda (#!optional given-path)
537       (sid (get-sid use-session))
538       (when (and (db-credentials) (db-enabled?) (not no-db))
539         (db-connection ((db-connect) (db-credentials))))
540       (page-javascript "")
541       (awful-refresh-session!)
542       (let ((out
543              (if (or (not (enable-session))
544                      no-session
545                      use-session
546                      (and (enable-session) (session-valid? (sid))))
547                  (if ((page-access-control) (or given-path path))
548                      (begin
549                        (when use-session
550                          (if (session-valid? (sid))
551                              (awful-refresh-session!)
552                              (begin
553                                (sid (session-create))
554                                ((session-cookie-setter) (sid)))))
555                        (let* ((ajax?
556                                (or (string? use-ajax)
557                                    (cond (no-ajax #f)
558                                          ((not (ajax-library)) #f)
559                                          ((and (ajax-library) use-ajax) #t)
560                                          ((enable-ajax) #t)
561                                          (else #f))))
562                               (contents
563                                (handle-exceptions exn
564                                  (begin
565                                    (%error exn)
566                                    (debug (with-output-to-string
567                                             (lambda ()
568                                               (print-call-chain)
569                                               (print-error-message exn))))
570                                    ((page-exception-message) exn))
571                                  (let ((resp
572                                         (if (regexp? path)
573                                             (contents given-path)
574                                             (contents))))
575                                    (if (procedure? resp)
576                                        resp
577                                        (++ resp
578                                            (if (eq? (javascript-position) 'bottom)
579                                                (include-page-javascript ajax? no-javascript-compression)
580                                                "")))))))
581                          (if (%redirect)
582                              #f ;; no need to do anything.  Let `run-resource' perform the redirection
583                              (if no-template
584                                  contents
585                                  ((page-template)
586                                   contents
587                                   css: (or css (page-css))
588                                   title: title
589                                   doctype: (or doctype (page-doctype))
590                                   headers: (++ (if ajax?
591                                                    (<script> type: "text/javascript"
592                                                              src: (if (string? use-ajax)
593                                                                       use-ajax
594                                                                       (ajax-library)))
595                                                    "")
596                                                (or headers "")
597                                                (if (eq? (javascript-position) 'top)
598                                                    (include-page-javascript ajax? no-javascript-compression)
599                                                    ""))
600                                   charset: (or charset (page-charset)))))))
601                      ((page-template) ((page-access-denied-message) (or given-path path))))
602                  ((page-template)
603                   ""
604                   headers: (<meta> http-equiv: "refresh"
605                                    content: (++ "0;url=" (login-page-path)
606                                                 "?reason=invalid-session&attempted-path=" (or given-path path)
607                                                 "&user=" ($ 'user "")
608                                                 (if (and (not (enable-session-cookie)) ($ 'sid))
609                                                     (++ "&sid=" ($ 'sid))
610                                                     "")))))))
611         (when (and (db-connection) (db-enabled?) (not no-db)) ((db-disconnect) (db-connection)))
612         out))
613     method))
614  path)
615
616(define (define-session-page path contents . rest)
617  ;; `rest' are same keyword params as for `define-page' (except `no-session', obviously)
618  (apply define-page (append (list path contents) (list use-session: #t) rest)))
619
620
621;;; Ajax
622(define (ajax path id event proc #!key (action 'html) (method 'POST) (arguments '())
623              target success no-session no-db no-page-javascript vhost-root-path
624              live content-type prelude update-targets (cache 'not-set) error-handler)
625  (let ((path (page-path path (ajax-namespace))))
626    (add-resource! path
627                   (or vhost-root-path (root-path))
628                   (lambda (#!optional given-path)
629                     (sid (get-sid 'force))
630                     (when update-targets
631                       (awful-response-headers '((content-type "application/json"))))
632                     (if (or (not (enable-session))
633                             no-session
634                             (and (enable-session) (session-valid? (sid))))
635                         (if ((page-access-control) path)
636                             (begin
637                               (when (and (db-credentials) (db-enabled?) (not no-db))
638                                 (db-connection ((db-connect) (db-credentials))))
639                               (awful-refresh-session!)
640                               (let ((out (if update-targets
641                                              (with-output-to-string
642                                                (lambda ()
643                                                  (json-write (list->vector (proc)))))
644                                              (proc))))
645                                 (when (and (db-credentials) (db-enabled?) (not no-db))
646                                   ((db-disconnect) (db-connection)))
647                                 out))
648                             ((page-access-denied-message) path))
649                         (ajax-invalid-session-message)))
650                   method)
651    (let* ((arguments (if (and (sid) (session-valid? (sid)))
652                          (cons `(sid . ,(++ "'" (sid) "'")) arguments)
653                          arguments))
654           (js-code
655            (++ (if (and id event)
656                    (let ((events (concat (if (list? event) event (list event)) " "))
657                          (binder (if live "live" "bind")))
658                      (++ "$('" (if (symbol? id)
659                                    (conc "#" id)
660                                    id)
661                          "')." binder "('" events "',"))
662                    "")
663                (++ "function(event){"
664                    (or prelude "")
665                    "$.ajax({type:'" (->string method) "',"
666                    "url:'" path "',"
667                    (if content-type
668                        (conc "contentType: '" content-type "',")
669                        "")
670                    "success:function(response){"
671                    (or success
672                        (cond (update-targets
673                               "$.each(response, function(id, html) { $('#' + id).html(html);});")
674                              (target
675                               (++ "$('#" target "')." (->string action) "(response);"))
676                              (else "return;")))
677                    "},"
678                    (if update-targets
679                        "dataType: 'json',"
680                        "")
681                    (if (eq? cache 'not-set)
682                        ""
683                        (if cache
684                            "cache:true,"
685                            "cache:false,"))
686                    (if error-handler
687                        (++ "error:" error-handler ",")
688                        "")
689                    (++ "data:{"
690                        (string-intersperse
691                         (map (lambda (var/val)
692                                (conc  "'" (car var/val) "':" (cdr var/val)))
693                              arguments)
694                         ",") "}")
695                    "})}")
696                (if (and id event)
697                    ");\n"
698                    ""))))
699      (unless no-page-javascript (add-javascript js-code))
700      js-code)))
701
702(define (periodical-ajax path interval proc #!key target (action 'html) (method 'POST)
703                         (arguments '()) success no-session no-db vhost-root-path live
704                         content-type prelude update-targets cache error-handler)
705  (add-javascript
706   (++ "setInterval("
707       (ajax path #f #f proc
708             target: target
709             action: action
710             method: method
711             arguments: arguments
712             success: success
713             no-session: no-session
714             no-db: no-db
715             vhost-root-path: vhost-root-path
716             live: live
717             content-type: content-type
718             prelude: prelude
719             update-targets: update-targets
720             error-handler: error-handler
721             cache: cache
722             no-page-javascript: #t)
723       ", " (->string interval) ");\n")))
724
725(define (ajax-link path id text proc #!key target (action 'html) (method 'POST) (arguments '())
726                   success no-session no-db (event 'click) vhost-root-path live class
727                   hreflang type rel rev charset coords shape accesskey tabindex a-target
728                   content-type prelude update-targets error-handler cache)
729  (ajax path id event proc
730        target: target
731        action: action
732        method: method
733        arguments: arguments
734        success: success
735        no-session: no-session
736        vhost-root-path: vhost-root-path
737        live: live
738        content-type: content-type
739        prelude: prelude
740        update-targets: update-targets
741        error-handler: error-handler
742        cache: cache
743        no-db: no-db)
744  (<a> href: "#"
745       id: id
746       class: class
747       hreflang: hreflang
748       type: type
749       rel: rel
750       rev: rev
751       charset: charset
752       coords: coords
753       shape: shape
754       accesskey: accesskey
755       tabindex: tabindex
756       target: a-target
757       text))
758
759
760;;; Login form
761(define (login-form #!key (user-label "User: ")
762                          (password-label "Password: ")
763                          (submit-label "Submit")
764                          (trampoline-path "/login-trampoline")
765                          (refill-user #t))
766  (let ((attempted-path ($ 'attempted-path))
767        (user ($ 'user)))
768    (<form> action: trampoline-path method: "post"
769            (if attempted-path
770                (hidden-input 'attempted-path attempted-path)
771                "")
772            (<span> id: "user-container"
773                    (<label> id: "user-label" for: "user" user-label)
774                    (<input> type: "text" id: "user" name: "user" value: (and refill-user user)))
775            (<span> id: "password-container"
776                    (<label> id: "password-label" for: "password" password-label)
777                    (<input> type: "password" id: "password" name: "password"))
778            (<input> type: "submit" id: "login-submit" value: submit-label))))
779
780
781;;; Login trampoline (for redirection)
782(define (define-login-trampoline path #!key vhost-root-path hook)
783  (define-page path
784    (lambda ()
785      (let* ((user ($ 'user))
786             (password ($ 'password))
787             (attempted-path ($ 'attempted-path))
788             (password-valid? ((valid-password?) user password))
789             (new-sid (and password-valid? (session-create))))
790        (sid new-sid)
791        (when (enable-session-cookie)
792          ((session-cookie-setter) new-sid))
793        (when hook (hook user))
794        (html-page
795         ""
796         headers: (<meta> http-equiv: "refresh"
797                          content: (++ "0;url="
798                                       (if new-sid
799                                           (++ (or attempted-path (main-page-path))
800                                               "?user=" user
801                                               (if (enable-session-cookie)
802                                                   ""
803                                                   (++ "&sid=" new-sid)))
804                                           (++ (login-page-path) "?reason=invalid-password&user=" user)))))))
805    method: 'POST
806    vhost-root-path: vhost-root-path
807    no-session: #t
808    no-template: #t))
809
810
811;;; Web repl
812(define (enable-web-repl path #!key css (title "Awful Web REPL") headers)
813  (unless (development-mode?) (%web-repl-path path))
814  (define-page path
815    (lambda ()
816      (if ((web-repl-access-control))
817          (let ((web-eval
818                 (lambda ()
819                   (<pre> convert-to-entities?: #t
820                          (with-output-to-string
821                            (lambda ()
822                              (pp (handle-exceptions
823                                   exn
824                                   (begin
825                                     (print-error-message exn)
826                                     (print-call-chain))
827                                   (eval `(begin
828                                            ,@(with-input-from-string ($ 'code "")
829                                                read-file)))))))))))
830            (page-javascript
831             (++ "$('#clear').click(function(){"
832                 (if (enable-web-repl-fancy-editor)
833                     "editor.setCode('');"
834                     "$('#prompt').val('');")
835                 "});"))
836
837            (ajax (++ path "-eval") 'eval 'click web-eval
838                  target: "result"
839                  arguments: `((code . ,(if (enable-web-repl-fancy-editor)
840                                            "editor.getCode()"
841                                            "$('#prompt').val()"))))
842
843            (when (enable-web-repl-fancy-editor)
844              (ajax (++ path "-eval") 'eval-region 'click web-eval
845                    target: "result"
846                    arguments: `((code . "editor.selection()"))))
847
848            (++ (<h1> title)
849                (<h2> "Input area")
850                (let ((prompt (<textarea> id: "prompt" name: "prompt" rows: "10" cols: "90")))
851                  (if (enable-web-repl-fancy-editor)
852                      (<div> class: "border" prompt)
853                      prompt))
854                (itemize
855                 (map (lambda (item)
856                        (<button> id: (car item) (cdr item)))
857                      (append '(("eval"  . "Eval"))
858                              (if (enable-web-repl-fancy-editor)
859                                  '(("eval-region" . "Eval region"))
860                                  '())
861                              '(("clear" . "Clear"))))
862                 list-id: "button-bar")
863                (<h2> "Output area")
864                (<div> id: "result")
865                (if (enable-web-repl-fancy-editor)
866                    (<script> type: "text/javascript" "
867  function addClass(element, className) {
868    if (!editor.win.hasClass(element, className)) {
869      element.className = ((element.className.split(' ')).concat([className])).join(' ');}}
870
871  function removeClass(element, className) {
872    if (editor.win.hasClass(element, className)) {
873      var classes = element.className.split(' ');
874      for (var i = classes.length - 1 ; i >= 0; i--) {
875        if (classes[i] === className) {
876            classes.splice(i, 1)}}
877      element.className = classes.join(' ');}}
878
879  var textarea = document.getElementById('prompt');
880  var editor = new CodeMirror(CodeMirror.replace(textarea), {
881    height: '250px',
882    width: '600px',
883    content: textarea.value,
884    parserfile: ['" (web-repl-fancy-editor-base-uri) "/tokenizescheme.js',
885                 '" (web-repl-fancy-editor-base-uri) "/parsescheme.js'],
886    stylesheet:  '" (web-repl-fancy-editor-base-uri) "/schemecolors.css',
887    autoMatchParens: true,
888    path: '" (web-repl-fancy-editor-base-uri) "/',
889    disableSpellcheck: true,
890    markParen: function(span, good) {addClass(span, good ? 'good-matching-paren' : 'bad-matching-paren');},
891    unmarkParen: function(span) {removeClass(span, 'good-matching-paren'); removeClass(span, 'bad-matching-paren');}
892  });")
893                    "")))
894          (web-repl-access-denied-message)))
895    headers: (++ (if (enable-web-repl-fancy-editor)
896                     (include-javascript (make-pathname (web-repl-fancy-editor-base-uri) "codemirror.js")
897                                         (make-pathname (web-repl-fancy-editor-base-uri) "mirrorframe.js"))
898                     "")
899                 (let ((builtin-css (if css
900                                        #f
901                                        (<style> type: "text/css"
902"h1 { font-size: 18pt; background-color: #898E79; width: 590px; color: white; padding: 5px;}
903h2 { font-size: 14pt; background-color: #898E79; width: 590px; color: white; padding: 5px;}
904ul#button-bar { margin-left: 0; padding-left: 0; }
905#button-bar li {display: inline; list-style-type: none; padding-right: 10px; }"
906(if (enable-web-repl-fancy-editor)
907    "div.border { border: 1px solid black; width: 600px;}"
908    "#prompt { width: 600px; }")
909"#result { border: 1px solid #333; padding: 5px; width: 590px; }"))))
910                   (if headers
911                       (++ (or builtin-css "") headers)
912                       builtin-css)))
913    use-ajax: #t
914    title: title
915    css: css))
916
917
918;;; Session inspector
919(define (enable-session-inspector path #!key css (title "Awful session inspector") headers)
920  (unless (development-mode?) (%session-inspector-path path))
921  (define-page path
922    (lambda ()
923      (parameterize ((enable-session #t))
924        (if ((session-inspector-access-control))
925            (let ((bindings (session-bindings (sid))))
926              (++ (<h1> title)
927                  (if (null? bindings)
928                      (<p> "Session for sid " (sid) " is empty")
929                      (++ (<p> "Session for " (sid))
930                          (tabularize
931                           (map (lambda (binding)
932                                  (let ((var (car binding))
933                                        (val (with-output-to-string
934                                               (lambda ()
935                                                 (pp (cdr binding))))))
936                                    (list (<span> class: "session-inspector-var" var)
937                                          (<pre> convert-to-entities?: #t
938                                                 class: "session-inspector-value"
939                                                 val))))
940                                bindings)
941                           header: '("Variables" "Values")
942                           table-id: "session-inspector-table")))))
943            (session-inspector-access-denied-message))))
944    headers: (let ((builtin-css (if css
945                                    #f
946                                    (<style> type: "text/css"
947"h1 { font-size: 16pt; background-color: #898E79; width: 590px; color: white; padding: 5px;}
948.session-inspector-value { margin: 2px;}
949.session-inspector-var { margin: 0px; }
950#session-inspector-table { margin: 0px; width: 600px;}
951#session-inspector-table tr td, th { padding-left: 10px; border: 1px solid #333; vertical-align: middle; }"))))
952               (if headers
953                   (++ (or builtin-css "") headers)
954                   builtin-css))
955    title: title
956    css: css))
957
958) ; end module
Note: See TracBrowser for help on using the repository browser.