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

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

awful: `add-request-handler-hook!' overwrites hooks with the same name instead of adding multiple copies

File size: 40.0 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 ((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?
554                                (or (string? use-ajax)
555                                    (cond (no-ajax #f)
556                                          ((not (ajax-library)) #f)
557                                          ((and (ajax-library) use-ajax) #t)
558                                          ((enable-ajax) #t)
559                                          (else #f))))
560                               (contents
561                                (handle-exceptions exn
562                                  (begin
563                                    (%error exn)
564                                    (debug (with-output-to-string
565                                             (lambda ()
566                                               (print-call-chain)
567                                               (print-error-message exn))))
568                                    ((page-exception-message) exn))
569                                  (++ (if (regexp? path)
570                                          (contents given-path)
571                                          (contents))
572                                      (if (eq? (javascript-position) 'bottom)
573                                          (include-page-javascript ajax? no-javascript-compression)
574                                          "")))))
575                          (if (%redirect)
576                              #f ;; no need to do anything.  Let `run-resource' perform the redirection
577                              (if no-template
578                                  contents
579                                  ((page-template)
580                                   contents
581                                   css: (or css (page-css))
582                                   title: title
583                                   doctype: (or doctype (page-doctype))
584                                   headers: (++ (if ajax?
585                                                    (<script> type: "text/javascript"
586                                                              src: (if (string? use-ajax)
587                                                                       use-ajax
588                                                                       (ajax-library)))
589                                                    "")
590                                                (or headers "")
591                                                (if (eq? (javascript-position) 'top)
592                                                    (include-page-javascript ajax? no-javascript-compression)
593                                                    ""))
594                                   charset: (or charset (page-charset)))))))
595                      ((page-template) ((page-access-denied-message) (or given-path path))))
596                  ((page-template)
597                   ""
598                   headers: (<meta> http-equiv: "refresh"
599                                    content: (++ "0;url=" (login-page-path)
600                                                 "?reason=invalid-session&attempted-path=" (or given-path path)
601                                                 "&user=" ($ 'user "")
602                                                 (if (and (not (enable-session-cookie)) ($ 'sid))
603                                                     (++ "&sid=" ($ 'sid))
604                                                     "")))))))
605         (when (and (db-connection) (db-enabled?) (not no-db)) ((db-disconnect) (db-connection)))
606         out))
607     method))
608  path)
609
610(define (define-session-page path contents . rest)
611  ;; `rest' are same keyword params as for `define-page' (except `no-session', obviously)
612  (apply define-page (append (list path contents) (list use-session: #t) rest)))
613
614
615;;; Ajax
616(define (ajax path id event proc #!key (action 'html) (method 'POST) (arguments '())
617              target success no-session no-db no-page-javascript vhost-root-path
618              live content-type prelude update-targets (cache 'not-set) error-handler)
619  (let ((path (page-path path (ajax-namespace))))
620    (add-resource! path
621                   (or vhost-root-path (root-path))
622                   (lambda (#!optional given-path)
623                     (sid (get-sid 'force))
624                     (when update-targets
625                       (awful-response-headers '((content-type "application/json"))))
626                     (if (or (not (enable-session))
627                             no-session
628                             (and (enable-session) (session-valid? (sid))))
629                         (if ((page-access-control) path)
630                             (begin
631                               (when (and (db-credentials) (db-enabled?) (not no-db))
632                                 (db-connection ((db-connect) (db-credentials))))
633                               (awful-refresh-session!)
634                               (let ((out (if update-targets
635                                              (with-output-to-string
636                                                (lambda ()
637                                                  (json-write (list->vector (proc)))))
638                                              (proc))))
639                                 (when (and (db-credentials) (db-enabled?) (not no-db))
640                                   ((db-disconnect) (db-connection)))
641                                 out))
642                             ((page-access-denied-message) path))
643                         (ajax-invalid-session-message)))
644                   method)
645    (let* ((arguments (if (and (sid) (session-valid? (sid)))
646                          (cons `(sid . ,(++ "'" (sid) "'")) arguments)
647                          arguments))
648           (js-code
649            (++ (if (and id event)
650                    (let ((events (concat (if (list? event) event (list event)) " "))
651                          (binder (if live "live" "bind")))
652                      (++ "$('" (if (symbol? id)
653                                    (conc "#" id)
654                                    id)
655                          "')." binder "('" events "',"))
656                    "")
657                (++ "function(event){"
658                    (or prelude "")
659                    "$.ajax({type:'" (->string method) "',"
660                    "url:'" path "',"
661                    (if content-type
662                        (conc "contentType: '" content-type "',")
663                        "")
664                    "success:function(response){"
665                    (or success
666                        (cond (update-targets
667                               "$.each(response, function(id, html) { $('#' + id).html(html);});")
668                              (target
669                               (++ "$('#" target "')." (->string action) "(response);"))
670                              (else "return;")))
671                    "},"
672                    (if update-targets
673                        "dataType: 'json',"
674                        "")
675                    (if (eq? cache 'not-set)
676                        ""
677                        (if cache
678                            "cache:true,"
679                            "cache:false,"))
680                    (if error-handler
681                        (++ "error:" error-handler ",")
682                        "")
683                    (++ "data:{"
684                        (string-intersperse
685                         (map (lambda (var/val)
686                                (conc  "'" (car var/val) "':" (cdr var/val)))
687                              arguments)
688                         ",") "}")
689                    "})}")
690                (if (and id event)
691                    ");\n"
692                    ""))))
693      (unless no-page-javascript (add-javascript js-code))
694      js-code)))
695
696(define (periodical-ajax path interval proc #!key target (action 'html) (method 'POST)
697                         (arguments '()) success no-session no-db vhost-root-path live
698                         content-type prelude update-targets cache error-handler)
699  (add-javascript
700   (++ "setInterval("
701       (ajax path #f #f proc
702             target: target
703             action: action
704             method: method
705             arguments: arguments
706             success: success
707             no-session: no-session
708             no-db: no-db
709             vhost-root-path: vhost-root-path
710             live: live
711             content-type: content-type
712             prelude: prelude
713             update-targets: update-targets
714             error-handler: error-handler
715             cache: cache
716             no-page-javascript: #t)
717       ", " (->string interval) ");\n")))
718
719(define (ajax-link path id text proc #!key target (action 'html) (method 'POST) (arguments '())
720                   success no-session no-db (event 'click) vhost-root-path live class
721                   hreflang type rel rev charset coords shape accesskey tabindex a-target
722                   content-type prelude update-targets error-handler cache)
723  (ajax path id event proc
724        target: target
725        action: action
726        method: method
727        arguments: arguments
728        success: success
729        no-session: no-session
730        vhost-root-path: vhost-root-path
731        live: live
732        content-type: content-type
733        prelude: prelude
734        update-targets: update-targets
735        error-handler: error-handler
736        cache: cache
737        no-db: no-db)
738  (<a> href: "#"
739       id: id
740       class: class
741       hreflang: hreflang
742       type: type
743       rel: rel
744       rev: rev
745       charset: charset
746       coords: coords
747       shape: shape
748       accesskey: accesskey
749       tabindex: tabindex
750       target: a-target
751       text))
752
753
754;;; Login form
755(define (login-form #!key (user-label "User: ")
756                          (password-label "Password: ")
757                          (submit-label "Submit")
758                          (trampoline-path "/login-trampoline")
759                          (refill-user #t))
760  (let ((attempted-path ($ 'attempted-path))
761        (user ($ 'user)))
762    (<form> action: trampoline-path method: "post"
763            (if attempted-path
764                (hidden-input 'attempted-path attempted-path)
765                "")
766            (<span> id: "user-container"
767                    (<label> id: "user-label" for: "user" user-label)
768                    (<input> type: "text" id: "user" name: "user" value: (and refill-user user)))
769            (<span> id: "password-container"
770                    (<label> id: "password-label" for: "password" password-label)
771                    (<input> type: "password" id: "password" name: "password"))
772            (<input> type: "submit" id: "login-submit" value: submit-label))))
773
774
775;;; Login trampoline (for redirection)
776(define (define-login-trampoline path #!key vhost-root-path hook)
777  (define-page path
778    (lambda ()
779      (let* ((user ($ 'user))
780             (password ($ 'password))
781             (attempted-path ($ 'attempted-path))
782             (password-valid? ((valid-password?) user password))
783             (new-sid (and password-valid? (session-create))))
784        (sid new-sid)
785        (when (enable-session-cookie)
786          ((session-cookie-setter) new-sid))
787        (when hook (hook user))
788        (html-page
789         ""
790         headers: (<meta> http-equiv: "refresh"
791                          content: (++ "0;url="
792                                       (if new-sid
793                                           (++ (or attempted-path (main-page-path))
794                                               "?user=" user
795                                               (if (enable-session-cookie)
796                                                   ""
797                                                   (++ "&sid=" new-sid)))
798                                           (++ (login-page-path) "?reason=invalid-password&user=" user)))))))
799    method: 'POST
800    vhost-root-path: vhost-root-path
801    no-session: #t
802    no-template: #t))
803
804
805;;; Web repl
806(define (enable-web-repl path #!key css (title "Awful Web REPL") headers)
807  (unless (development-mode?) (%web-repl-path path))
808  (define-page path
809    (lambda ()
810      (if ((web-repl-access-control))
811          (let ((web-eval
812                 (lambda ()
813                   (<pre> convert-to-entities?: #t
814                          (with-output-to-string
815                            (lambda ()
816                              (pp (handle-exceptions
817                                   exn
818                                   (begin
819                                     (print-error-message exn)
820                                     (print-call-chain))
821                                   (eval `(begin
822                                            ,@(with-input-from-string ($ 'code "")
823                                                read-file)))))))))))
824            (page-javascript
825             (++ "$('#clear').click(function(){"
826                 (if (enable-web-repl-fancy-editor)
827                     "editor.setCode('');"
828                     "$('#prompt').val('');")
829                 "});"))
830
831            (ajax (++ path "-eval") 'eval 'click web-eval
832                  target: "result"
833                  arguments: `((code . ,(if (enable-web-repl-fancy-editor)
834                                            "editor.getCode()"
835                                            "$('#prompt').val()"))))
836
837            (when (enable-web-repl-fancy-editor)
838              (ajax (++ path "-eval") 'eval-region 'click web-eval
839                    target: "result"
840                    arguments: `((code . "editor.selection()"))))
841
842            (++ (<h1> title)
843                (<h2> "Input area")
844                (let ((prompt (<textarea> id: "prompt" name: "prompt" rows: "10" cols: "90")))
845                  (if (enable-web-repl-fancy-editor)
846                      (<div> class: "border" prompt)
847                      prompt))
848                (itemize
849                 (map (lambda (item)
850                        (<button> id: (car item) (cdr item)))
851                      (append '(("eval"  . "Eval"))
852                              (if (enable-web-repl-fancy-editor)
853                                  '(("eval-region" . "Eval region"))
854                                  '())
855                              '(("clear" . "Clear"))))
856                 list-id: "button-bar")
857                (<h2> "Output area")
858                (<div> id: "result")
859                (if (enable-web-repl-fancy-editor)
860                    (<script> type: "text/javascript" "
861  function addClass(element, className) {
862    if (!editor.win.hasClass(element, className)) {
863      element.className = ((element.className.split(' ')).concat([className])).join(' ');}}
864
865  function removeClass(element, className) {
866    if (editor.win.hasClass(element, className)) {
867      var classes = element.className.split(' ');
868      for (var i = classes.length - 1 ; i >= 0; i--) {
869        if (classes[i] === className) {
870            classes.splice(i, 1)}}
871      element.className = classes.join(' ');}}
872
873  var textarea = document.getElementById('prompt');
874  var editor = new CodeMirror(CodeMirror.replace(textarea), {
875    height: '250px',
876    width: '600px',
877    content: textarea.value,
878    parserfile: ['" (web-repl-fancy-editor-base-uri) "/tokenizescheme.js',
879                 '" (web-repl-fancy-editor-base-uri) "/parsescheme.js'],
880    stylesheet:  '" (web-repl-fancy-editor-base-uri) "/schemecolors.css',
881    autoMatchParens: true,
882    path: '" (web-repl-fancy-editor-base-uri) "/',
883    disableSpellcheck: true,
884    markParen: function(span, good) {addClass(span, good ? 'good-matching-paren' : 'bad-matching-paren');},
885    unmarkParen: function(span) {removeClass(span, 'good-matching-paren'); removeClass(span, 'bad-matching-paren');}
886  });")
887                    "")))
888          (web-repl-access-denied-message)))
889    headers: (++ (if (enable-web-repl-fancy-editor)
890                     (include-javascript (make-pathname (web-repl-fancy-editor-base-uri) "codemirror.js")
891                                         (make-pathname (web-repl-fancy-editor-base-uri) "mirrorframe.js"))
892                     "")
893                 (let ((builtin-css (if css
894                                        #f
895                                        (<style> type: "text/css"
896"h1 { font-size: 18pt; background-color: #898E79; width: 590px; color: white; padding: 5px;}
897h2 { font-size: 14pt; background-color: #898E79; width: 590px; color: white; padding: 5px;}
898ul#button-bar { margin-left: 0; padding-left: 0; }
899#button-bar li {display: inline; list-style-type: none; padding-right: 10px; }"
900(if (enable-web-repl-fancy-editor)
901    "div.border { border: 1px solid black; width: 600px;}"
902    "#prompt { width: 600px; }")
903"#result { border: 1px solid #333; padding: 5px; width: 590px; }"))))
904                   (if headers
905                       (++ (or builtin-css "") headers)
906                       builtin-css)))
907    use-ajax: #t
908    title: title
909    css: css))
910
911
912;;; Session inspector
913(define (enable-session-inspector path #!key css (title "Awful session inspector") headers)
914  (unless (development-mode?) (%session-inspector-path path))
915  (define-page path
916    (lambda ()
917      (parameterize ((enable-session #t))
918        (if ((session-inspector-access-control))
919            (let ((bindings (session-bindings (sid))))
920              (++ (<h1> title)
921                  (if (null? bindings)
922                      (<p> "Session for sid " (sid) " is empty")
923                      (++ (<p> "Session for " (sid))
924                          (tabularize
925                           (map (lambda (binding)
926                                  (let ((var (car binding))
927                                        (val (with-output-to-string
928                                               (lambda ()
929                                                 (pp (cdr binding))))))
930                                    (list (<span> class: "session-inspector-var" var)
931                                          (<pre> convert-to-entities?: #t
932                                                 class: "session-inspector-value"
933                                                 val))))
934                                bindings)
935                           header: '("Variables" "Values")
936                           table-id: "session-inspector-table")))))
937            (session-inspector-access-denied-message))))
938    headers: (let ((builtin-css (if css
939                                    #f
940                                    (<style> type: "text/css"
941"h1 { font-size: 16pt; background-color: #898E79; width: 590px; color: white; padding: 5px;}
942.session-inspector-value { margin: 2px;}
943.session-inspector-var { margin: 0px; }
944#session-inspector-table { margin: 0px; width: 600px;}
945#session-inspector-table tr td, th { padding-left: 10px; border: 1px solid #333; vertical-align: middle; }"))))
946               (if headers
947                   (++ (or builtin-css "") headers)
948                   builtin-css))
949    title: title
950    css: css))
951
952) ; end module
Note: See TracBrowser for help on using the repository browser.