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

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

awful: jquery updated to version 1.7.1

File size: 39.6 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 (zero? (current-effective-user-id))
222      (print "WARNING: awful is running with administrator privileges (not recommended)"))
223    ;; load apps
224    (thunk)
225    ;; Check for invalid javascript positioning
226    (unless (memq (javascript-position) '(top bottom))
227      (error 'awful-start
228             "Invalid value for `javascript-position'.  Valid ones are: `top' and `bottom'."))
229    (register-root-dir-handler)
230    (register-dispatcher)
231    (accept-loop listener (awful-accept))))
232
233(define (get-sid #!optional force-read-sid)
234  (and (or (enable-session) force-read-sid)
235       (if (enable-session-cookie)
236           (or (read-cookie (session-cookie-name)) ($ 'sid))
237           ($ 'sid))))
238
239(define (redirect-to new-uri)
240  ;; Just set the `%redirect' internal parameter, so `run-resource' is
241  ;; able to know where to redirect.
242  (%redirect new-uri)
243  "")
244
245
246;;; Javascript
247(define (include-javascript . files)
248  (string-intersperse
249   (map (lambda (file)
250          (<script> type: "text/javascript" src: file))
251        files)))
252
253(define (add-javascript . code)
254  (page-javascript (++ (page-javascript) (concat code))))
255
256(define (maybe-compress-javascript js no-javascript-compression)
257  (if (and (enable-javascript-compression)
258           (javascript-compressor)
259           (not no-javascript-compression))
260      (string-trim-both ((javascript-compressor) js))
261      js))
262
263
264;;; Debugging
265(define (debug . args)
266  (when (debug-file)
267    (with-output-to-file (debug-file)
268      (lambda ()
269        (print (concat args)))
270      append:)))
271
272(define (debug-pp arg)
273  (when (debug-file)
274    (with-output-to-file (debug-file) (cut pp arg) append:)))
275
276
277;;; Session access
278(define ($session var #!optional default)
279  (session-ref (sid) (string->symbol* var) default))
280
281(define ($session-set! var #!optional val)
282  (if (list? var)
283      (for-each (lambda (var/val)
284                  (session-set! (sid) (string->symbol* (car var/val)) (cdr var/val)))
285                var)
286      (session-set! (sid) (string->symbol* var) val)))
287
288(define (awful-refresh-session!)
289  (when (and (enable-session) (session-valid? (sid)))
290    (session-refresh! (sid))))
291
292
293;;; Session-aware procedures for HTML code generation
294(define (link url text . rest)
295  (let ((pass-sid? (and (not (enable-session-cookie))
296                        (sid)
297                        (session-valid? (sid))
298                        (not (get-keyword no-session: rest))))
299        (arguments (or (get-keyword arguments: rest) '()))
300        (separator (or (get-keyword separator: rest) ";&")))
301    (apply <a>
302           (append
303            (list href: (if url
304                            (++ url
305                                (if (or pass-sid? (not (null? arguments)))
306                                    (++ "?"
307                                        (form-urlencode
308                                         (append arguments
309                                                 (if pass-sid?
310                                                     `((sid . ,(sid)))
311                                                     '()))
312                                         separator: separator))
313                                    ""))
314                            "#"))
315            rest
316            (list text)))))
317
318(define (form contents . rest)
319  (let ((pass-sid? (and (not (enable-session-cookie))
320                        (sid)
321                        (session-valid? (sid))
322                        (not (get-keyword no-session: rest)))))
323    (apply <form>
324           (append rest
325                   (list
326                    (++ (if pass-sid?
327                            (hidden-input 'sid (sid))
328                            "")
329                        contents))))))
330
331
332;;; HTTP request variables access
333(define ($ var #!optional default/converter)
334  (unless (http-request-variables)
335    (http-request-variables (request-vars)))
336  ((http-request-variables) var default/converter))
337
338
339;;; DB access
340(define ($db q #!key default values)
341  (unless (db-enabled?)
342    (error '$db "Database access doesn't seem to be enabled. Did you call `(enable-db)'?"))
343  (debug-query q)
344  ((db-inquirer) q default: default values: values))
345
346(define (debug-query q)
347  (when (and (debug-file) (debug-db-query?))
348    (debug (++ (debug-db-query-prefix) q))))
349
350(define ($db-row-obj q)
351  (debug-query q)
352  ((db-make-row-obj) q))
353
354(define (sql-quote . data)
355  ((sql-quoter) data))
356
357
358;;; Parameters reseting
359(define (reset-per-request-parameters) ;; to cope with spiffy's thread reuse
360  (http-request-variables #f)
361  (awful-response-headers #f)
362  (db-connection #f)
363  (sid #f)
364  (%redirect #f)
365  (%error #f))
366
367
368;;; Request handling hooks
369(define *request-handler-hooks* '())
370
371(define (add-request-handler-hook! name proc)
372  (set! *request-handler-hooks*
373        (cons (cons name proc) *request-handler-hooks*)))
374
375(define (remove-request-handler-hook! name)
376  (set! *request-handler-hooks*
377        (alist-delete! name *request-handler-hooks*)))
378
379;;; Resources
380(root-path (current-directory))
381
382(define *resources* (make-hash-table equal?))
383
384(define (register-dispatcher)
385  (handle-not-found
386   (let ((old-handler (handle-not-found)))
387     (lambda (_)
388       (let* ((path-list (uri-path (request-uri (current-request))))
389              (method (request-method (current-request)))
390              (dir? (equal? (last path-list) ""))
391              (path (if (null? (cdr path-list))
392                        (car path-list)
393                        (++ "/" (concat (cdr path-list) "/"))))
394              (proc (resource-ref path (root-path) method)))
395         (if proc
396             (run-resource proc path)
397             (if dir? ;; try to find a procedure with the trailing slash removed
398                 (let ((proc (resource-ref (string-chomp path "/") (root-path) method)))
399                   (if proc
400                       (run-resource proc path)
401                       (old-handler _)))
402                 (old-handler _))))))))
403
404(define (run-resource proc path)
405  (reset-per-request-parameters)
406  (let ((handler
407         (lambda (path proc)
408           (let ((out (->string (proc path))))
409             (if (%error)
410                 (send-response code: 500
411                                reason: "Internal server error"
412                                body: ((page-template) ((page-exception-message) (%error)))
413                                headers: '((content-type text/html)))
414                 (if (%redirect) ;; redirection
415                     (let ((new-uri (if (string? (%redirect))
416                                        (uri-reference (%redirect))
417                                        (%redirect))))
418                       (with-headers `((location ,new-uri))
419                                     (lambda ()
420                                       (send-status 302 "Found"))))
421                     (with-headers (append
422                                    (or (awful-response-headers)
423                                        `((content-type text/html)))
424                                    (or (and-let* ((headers (awful-response-headers))
425                                                   (content-length (alist-ref 'content-length headers)))
426                                          (list (cons 'content-length content-length)))
427                                        `((content-length ,(string-length out)))))
428                                   (lambda ()
429                                     (write-logged-response)
430                                     (unless (eq? 'HEAD (request-method (current-request)))
431                                       (display out (response-port (current-response))))))))))))
432    (call/cc (lambda (continue)
433               (for-each (lambda (hook)
434                           ((cdr hook) path
435                                       (lambda ()
436                                         (handler path proc)
437                                         (continue #f))))
438                         *request-handler-hooks*)
439               (handler path proc)))))
440
441(define (resource-ref path vhost-root-path method)
442  (when (debug-resources)
443    (debug-pp (hash-table->alist *resources*)))
444  (if (list? method)
445      (let loop ((methods '(POST GET PUT DELETE HEAD)))
446        (if (null? methods)
447            #f
448            (let ((method (car methods)))
449              (or (hash-table-ref/default *resources*
450                                          (list path vhost-root-path method)
451                                          #f)
452                  (resource-match path vhost-root-path method)
453                  (loop (cdr methods))))))
454      (or (hash-table-ref/default *resources* (list path vhost-root-path method) #f)
455          (resource-match path vhost-root-path method))))
456
457(define (resource-match path vhost-root-path method)
458  (let loop ((resources (hash-table->alist *resources*)))
459    (if (null? resources)
460        #f
461        (let* ((current-resource (car resources))
462               (current-path (caar current-resource))
463               (current-vhost (cadar current-resource))
464               (current-method (caddar current-resource))
465               (current-proc (cdr current-resource)))
466          (if (and (regexp? current-path)
467                   (equal? current-vhost vhost-root-path)
468                   (eq? current-method method)
469                   (string-match current-path path))
470              current-proc
471              (loop (cdr resources)))))))
472
473(define (add-resource! path vhost-root-path proc method)
474  (let ((methods (if (list? method) method (list method))))
475    (for-each
476     (lambda (method)
477       (let ((upcase-method
478              (string->symbol (string-upcase (symbol->string method)))))
479         (hash-table-set! *resources* (list path vhost-root-path upcase-method) proc)))
480     methods)))
481
482(define (reset-resources!)
483  (set! *resources* (make-hash-table equal?)))
484
485;;; Root dir
486(define (register-root-dir-handler)
487  (handle-directory
488   (let ((old-handler (handle-directory)))
489     (lambda (path)
490       (cond ((resource-ref path (root-path) (request-method (current-request)))
491              => (cut run-resource <> path))
492             (else (old-handler path)))))))
493
494;;; Pages
495(define (undefine-page path #!key vhost-root-path (method 'GET))
496  (hash-table-delete! *resources* (list path (or vhost-root-path (root-path)) method)))
497
498(define (include-page-javascript ajax? no-javascript-compression)
499  (if ajax?
500      (<script> type: "text/javascript"
501                (maybe-compress-javascript
502                 (++ "$(document).ready(function(){"
503                     (page-javascript) "});")
504                 no-javascript-compression))
505      (if (string-null? (page-javascript))
506          ""
507          (<script> type: "text/javascript"
508                    (maybe-compress-javascript
509                     (page-javascript)
510                     no-javascript-compression)))))
511
512(define (page-path path #!optional namespace)
513  (cond ((regexp? path) path)
514        ((equal? path "/") "/")
515        (else
516         (string-chomp
517          (make-pathname (cons (app-root-path)
518                               (if namespace
519                                   (list namespace)
520                                   '()))
521                         path)
522          "/"))))
523
524(define (define-page path contents #!key css title doctype headers charset no-ajax
525                     no-template no-session no-db vhost-root-path no-javascript-compression
526                     use-ajax (method 'GET)
527                     use-session) ;; for define-session-page
528  (##sys#check-closure contents 'define-page)
529  (let ((path (page-path path)))
530    (add-resource!
531     path
532     (or vhost-root-path (root-path))
533     (lambda (#!optional given-path)
534       (sid (get-sid use-session))
535       (when (and (db-credentials) (db-enabled?) (not no-db))
536         (db-connection ((db-connect) (db-credentials))))
537       (page-javascript "")
538       (awful-refresh-session!)
539       (let ((out
540              (if (or (not (enable-session))
541                      no-session
542                      use-session
543                      (and (enable-session) (session-valid? (sid))))
544                  (if ((page-access-control) (or given-path path))
545                      (begin
546                        (when use-session
547                          (if (session-valid? (sid))
548                              (awful-refresh-session!)
549                              (begin
550                                (sid (session-create))
551                                ((session-cookie-setter) (sid)))))
552                        (let* ((ajax? (cond (no-ajax #f)
553                                            ((not (ajax-library)) #f)
554                                            ((and (ajax-library) use-ajax) #t)
555                                            ((enable-ajax) #t)
556                                            (else #f)))
557                               (contents
558                                (handle-exceptions exn
559                                  (begin
560                                    (%error exn)
561                                    (debug (with-output-to-string
562                                             (lambda ()
563                                               (print-call-chain)
564                                               (print-error-message exn))))
565                                    ((page-exception-message) exn))
566                                  (++ (if (regexp? path)
567                                          (contents given-path)
568                                          (contents))
569                                      (if (eq? (javascript-position) 'bottom)
570                                          (include-page-javascript ajax? no-javascript-compression)
571                                          "")))))
572                          (if (%redirect)
573                              #f ;; no need to do anything.  Let `run-resource' perform the redirection
574                              (if no-template
575                                  contents
576                                  ((page-template)
577                                   contents
578                                   css: (or css (page-css))
579                                   title: title
580                                   doctype: (or doctype (page-doctype))
581                                   headers: (++ (if ajax?
582                                                    (<script> type: "text/javascript" src: (ajax-library))
583                                                    "")
584                                                (or headers "")
585                                                (if (eq? (javascript-position) 'top)
586                                                    (include-page-javascript ajax? no-javascript-compression)
587                                                    ""))
588                                   charset: (or charset (page-charset)))))))
589                      ((page-template) ((page-access-denied-message) (or given-path path))))
590                  ((page-template)
591                   ""
592                   headers: (<meta> http-equiv: "refresh"
593                                    content: (++ "0;url=" (login-page-path)
594                                                 "?reason=invalid-session&attempted-path=" (or given-path path)
595                                                 "&user=" ($ 'user "")
596                                                 (if (and (not (enable-session-cookie)) ($ 'sid))
597                                                     (++ "&sid=" ($ 'sid))
598                                                     "")))))))
599         (when (and (db-connection) (db-enabled?) (not no-db)) ((db-disconnect) (db-connection)))
600         out))
601     method))
602  path)
603
604(define (define-session-page path contents . rest)
605  ;; `rest' are same keyword params as for `define-page' (except `no-session', obviously)
606  (apply define-page (append (list path contents) (list use-session: #t) rest)))
607
608
609;;; Ajax
610(define (ajax path id event proc #!key (action 'html) (method 'POST) (arguments '())
611              target success no-session no-db no-page-javascript vhost-root-path
612              live content-type prelude update-targets (cache 'not-set) error-handler)
613  (let ((path (page-path path (ajax-namespace))))
614    (add-resource! path
615                   (or vhost-root-path (root-path))
616                   (lambda (#!optional given-path)
617                     (sid (get-sid 'force))
618                     (when update-targets
619                       (awful-response-headers '((content-type "application/json"))))
620                     (if (or (not (enable-session))
621                             no-session
622                             (and (enable-session) (session-valid? (sid))))
623                         (if ((page-access-control) path)
624                             (begin
625                               (when (and (db-credentials) (db-enabled?) (not no-db))
626                                 (db-connection ((db-connect) (db-credentials))))
627                               (awful-refresh-session!)
628                               (let ((out (if update-targets
629                                              (with-output-to-string
630                                                (lambda ()
631                                                  (json-write (list->vector (proc)))))
632                                              (proc))))
633                                 (when (and (db-credentials) (db-enabled?) (not no-db))
634                                   ((db-disconnect) (db-connection)))
635                                 out))
636                             ((page-access-denied-message) path))
637                         (ajax-invalid-session-message)))
638                   method)
639    (let* ((arguments (if (and (sid) (session-valid? (sid)))
640                          (cons `(sid . ,(++ "'" (sid) "'")) arguments)
641                          arguments))
642           (js-code
643            (++ (if (and id event)
644                    (let ((events (concat (if (list? event) event (list event)) " "))
645                          (binder (if live "live" "bind")))
646                      (++ "$('" (if (symbol? id)
647                                    (conc "#" id)
648                                    id)
649                          "')." binder "('" events "',"))
650                    "")
651                (++ "function(event){"
652                    (or prelude "")
653                    "$.ajax({type:'" (->string method) "',"
654                    "url:'" path "',"
655                    (if content-type
656                        (conc "contentType: '" content-type "',")
657                        "")
658                    "success:function(response){"
659                    (or success
660                        (cond (update-targets
661                               "$.each(response, function(id, html) { $('#' + id).html(html);});")
662                              (target
663                               (++ "$('#" target "')." (->string action) "(response);"))
664                              (else "return;")))
665                    "},"
666                    (if update-targets
667                        "dataType: 'json',"
668                        "")
669                    (if (eq? cache 'not-set)
670                        ""
671                        (if cache
672                            "cache:true,"
673                            "cache:false,"))
674                    (if error-handler
675                        (++ "error:" error-handler ",")
676                        "")
677                    (++ "data:{"
678                        (string-intersperse
679                         (map (lambda (var/val)
680                                (conc  "'" (car var/val) "':" (cdr var/val)))
681                              arguments)
682                         ",") "}")
683                    "})}")
684                (if (and id event)
685                    ");\n"
686                    ""))))
687      (unless no-page-javascript (add-javascript js-code))
688      js-code)))
689
690(define (periodical-ajax path interval proc #!key target (action 'html) (method 'POST)
691                         (arguments '()) success no-session no-db vhost-root-path live
692                         content-type prelude update-targets cache error-handler)
693  (add-javascript
694   (++ "setInterval("
695       (ajax path #f #f proc
696             target: target
697             action: action
698             method: method
699             arguments: arguments
700             success: success
701             no-session: no-session
702             no-db: no-db
703             vhost-root-path: vhost-root-path
704             live: live
705             content-type: content-type
706             prelude: prelude
707             update-targets: update-targets
708             error-handler: error-handler
709             cache: cache
710             no-page-javascript: #t)
711       ", " (->string interval) ");\n")))
712
713(define (ajax-link path id text proc #!key target (action 'html) (method 'POST) (arguments '())
714                   success no-session no-db (event 'click) vhost-root-path live class
715                   hreflang type rel rev charset coords shape accesskey tabindex a-target
716                   content-type prelude update-targets error-handler cache)
717  (ajax path id event proc
718        target: target
719        action: action
720        method: method
721        arguments: arguments
722        success: success
723        no-session: no-session
724        vhost-root-path: vhost-root-path
725        live: live
726        content-type: content-type
727        prelude: prelude
728        update-targets: update-targets
729        error-handler: error-handler
730        cache: cache
731        no-db: no-db)
732  (<a> href: "#"
733       id: id
734       class: class
735       hreflang: hreflang
736       type: type
737       rel: rel
738       rev: rev
739       charset: charset
740       coords: coords
741       shape: shape
742       accesskey: accesskey
743       tabindex: tabindex
744       target: a-target
745       text))
746
747
748;;; Login form
749(define (login-form #!key (user-label "User: ")
750                          (password-label "Password: ")
751                          (submit-label "Submit")
752                          (trampoline-path "/login-trampoline")
753                          (refill-user #t))
754  (let ((attempted-path ($ 'attempted-path))
755        (user ($ 'user)))
756    (<form> action: trampoline-path method: "post"
757            (if attempted-path
758                (hidden-input 'attempted-path attempted-path)
759                "")
760            (<span> id: "user-container"
761                    (<span> id: "user-label" user-label)
762                    (<input> type: "text" id: "user" name: "user" value: (and refill-user user)))
763            (<span> id: "password-container"
764                    (<span> id: "password-label" password-label)
765                    (<input> type: "password" id: "password" name: "password"))
766            (<input> type: "submit" id: "login-submit" value: submit-label))))
767
768
769;;; Login trampoline (for redirection)
770(define (define-login-trampoline path #!key vhost-root-path hook)
771  (define-page path
772    (lambda ()
773      (let* ((user ($ 'user))
774             (password ($ 'password))
775             (attempted-path ($ 'attempted-path))
776             (password-valid? ((valid-password?) user password))
777             (new-sid (and password-valid? (session-create))))
778        (sid new-sid)
779        (when (enable-session-cookie)
780          ((session-cookie-setter) new-sid))
781        (when hook (hook user))
782        (html-page
783         ""
784         headers: (<meta> http-equiv: "refresh"
785                          content: (++ "0;url="
786                                       (if new-sid
787                                           (++ (or attempted-path (main-page-path))
788                                               "?user=" user
789                                               (if (enable-session-cookie)
790                                                   ""
791                                                   (++ "&sid=" new-sid)))
792                                           (++ (login-page-path) "?reason=invalid-password&user=" user)))))))
793    method: 'POST
794    vhost-root-path: vhost-root-path
795    no-session: #t
796    no-template: #t))
797
798
799;;; Web repl
800(define (enable-web-repl path #!key css (title "Awful Web REPL") headers)
801  (unless (development-mode?) (%web-repl-path path))
802  (define-page path
803    (lambda ()
804      (if ((web-repl-access-control))
805          (let ((web-eval
806                 (lambda ()
807                   (<pre> convert-to-entities?: #t
808                          (with-output-to-string
809                            (lambda ()
810                              (pp (handle-exceptions
811                                   exn
812                                   (begin
813                                     (print-error-message exn)
814                                     (print-call-chain))
815                                   (eval `(begin
816                                            ,@(with-input-from-string ($ 'code "")
817                                                read-file)))))))))))
818            (page-javascript
819             (++ "$('#clear').click(function(){"
820                 (if (enable-web-repl-fancy-editor)
821                     "editor.setCode('');"
822                     "$('#prompt').val('');")
823                 "});"))
824
825            (ajax (++ path "-eval") 'eval 'click web-eval
826                  target: "result"
827                  arguments: `((code . ,(if (enable-web-repl-fancy-editor)
828                                            "editor.getCode()"
829                                            "$('#prompt').val()"))))
830
831            (when (enable-web-repl-fancy-editor)
832              (ajax (++ path "-eval") 'eval-region 'click web-eval
833                    target: "result"
834                    arguments: `((code . "editor.selection()"))))
835
836            (++ (<h1> title)
837                (<h2> "Input area")
838                (let ((prompt (<textarea> id: "prompt" name: "prompt" rows: "10" cols: "90")))
839                  (if (enable-web-repl-fancy-editor)
840                      (<div> class: "border" prompt)
841                      prompt))
842                (itemize
843                 (map (lambda (item)
844                        (<button> id: (car item) (cdr item)))
845                      (append '(("eval"  . "Eval"))
846                              (if (enable-web-repl-fancy-editor)
847                                  '(("eval-region" . "Eval region"))
848                                  '())
849                              '(("clear" . "Clear"))))
850                 list-id: "button-bar")
851                (<h2> "Output area")
852                (<div> id: "result")
853                (if (enable-web-repl-fancy-editor)
854                    (<script> type: "text/javascript" "
855  function addClass(element, className) {
856    if (!editor.win.hasClass(element, className)) {
857      element.className = ((element.className.split(' ')).concat([className])).join(' ');}}
858
859  function removeClass(element, className) {
860    if (editor.win.hasClass(element, className)) {
861      var classes = element.className.split(' ');
862      for (var i = classes.length - 1 ; i >= 0; i--) {
863        if (classes[i] === className) {
864            classes.splice(i, 1)}}
865      element.className = classes.join(' ');}}
866
867  var textarea = document.getElementById('prompt');
868  var editor = new CodeMirror(CodeMirror.replace(textarea), {
869    height: '250px',
870    width: '600px',
871    content: textarea.value,
872    parserfile: ['" (web-repl-fancy-editor-base-uri) "/tokenizescheme.js',
873                 '" (web-repl-fancy-editor-base-uri) "/parsescheme.js'],
874    stylesheet:  '" (web-repl-fancy-editor-base-uri) "/schemecolors.css',
875    autoMatchParens: true,
876    path: '" (web-repl-fancy-editor-base-uri) "/',
877    disableSpellcheck: true,
878    markParen: function(span, good) {addClass(span, good ? 'good-matching-paren' : 'bad-matching-paren');},
879    unmarkParen: function(span) {removeClass(span, 'good-matching-paren'); removeClass(span, 'bad-matching-paren');}
880  });")
881                    "")))
882          (web-repl-access-denied-message)))
883    headers: (++ (if (enable-web-repl-fancy-editor)
884                     (include-javascript (make-pathname (web-repl-fancy-editor-base-uri) "codemirror.js")
885                                         (make-pathname (web-repl-fancy-editor-base-uri) "mirrorframe.js"))
886                     "")
887                 (let ((builtin-css (if css
888                                        #f
889                                        (<style> type: "text/css"
890"h1 { font-size: 18pt; background-color: #898E79; width: 590px; color: white; padding: 5px;}
891h2 { font-size: 14pt; background-color: #898E79; width: 590px; color: white; padding: 5px;}
892ul#button-bar { margin-left: 0; padding-left: 0; }
893#button-bar li {display: inline; list-style-type: none; padding-right: 10px; }"
894(if (enable-web-repl-fancy-editor)
895    "div.border { border: 1px solid black; width: 600px;}"
896    "#prompt { width: 600px; }")
897"#result { border: 1px solid #333; padding: 5px; width: 590px; }"))))
898                   (if headers
899                       (++ (or builtin-css "") headers)
900                       builtin-css)))
901    use-ajax: #t
902    title: title
903    css: css))
904
905
906;;; Session inspector
907(define (enable-session-inspector path #!key css (title "Awful session inspector") headers)
908  (unless (development-mode?) (%session-inspector-path path))
909  (define-page path
910    (lambda ()
911      (parameterize ((enable-session #t))
912        (if ((session-inspector-access-control))
913            (let ((bindings (session-bindings (sid))))
914              (++ (<h1> title)
915                  (if (null? bindings)
916                      (<p> "Session for sid " (sid) " is empty")
917                      (++ (<p> "Session for " (sid))
918                          (tabularize
919                           (map (lambda (binding)
920                                  (let ((var (car binding))
921                                        (val (with-output-to-string
922                                               (lambda ()
923                                                 (pp (cdr binding))))))
924                                    (list (<span> class: "session-inspector-var" var)
925                                          (<pre> convert-to-entities?: #t
926                                                 class: "session-inspector-value"
927                                                 val))))
928                                bindings)
929                           header: '("Variables" "Values")
930                           table-id: "session-inspector-table")))))
931            (session-inspector-access-denied-message))))
932    headers: (let ((builtin-css (if css
933                                    #f
934                                    (<style> type: "text/css"
935"h1 { font-size: 16pt; background-color: #898E79; width: 590px; color: white; padding: 5px;}
936.session-inspector-value { margin: 2px;}
937.session-inspector-var { margin: 0px; }
938#session-inspector-table { margin: 0px; width: 600px;}
939#session-inspector-table tr td, th { padding-left: 10px; border: 1px solid #333; vertical-align: middle; }"))))
940               (if headers
941                   (++ (or builtin-css "") headers)
942                   builtin-css))
943    title: title
944    css: css))
945
946) ; end module
Note: See TracBrowser for help on using the repository browser.