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

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

awful (trunk): ajax-link' and periodical-ajax' also support `update-targets'.

File size: 25.3 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
14   ;; Procedures
15   ++ concat include-javascript add-javascript debug debug-pp $session
16   $session-set! $ $db $db-row-obj sql-quote define-page define-session-page
17   ajax ajax-link periodical-ajax login-form define-login-trampoline
18   enable-web-repl enable-session-inspector awful-version load-apps
19   link form
20
21   ;; Required by the awful server
22   add-resource! register-dispatcher register-root-dir-handler awful-start
23
24   ;; Required by db-support eggs
25   db-enabled? db-inquirer db-connect db-disconnect sql-quoter db-make-row-obj
26
27  ) ; end export list
28
29(import scheme chicken data-structures utils extras regex ports srfi-69 files srfi-1)
30
31;; Units
32(use posix srfi-13)
33
34;; Eggs
35(use intarweb spiffy spiffy-request-vars html-tags html-utils uri-common
36     http-session json)
37
38;;; Version
39(define (awful-version) "0.22")
40
41
42;;; Parameters
43
44;; User-configurable parameters
45(define awful-apps (make-parameter '()))
46(define debug-file (make-parameter #f))
47(define debug-db-query? (make-parameter #t))
48(define debug-db-query-prefix (make-parameter ""))
49(define db-credentials (make-parameter #f))
50(define ajax-library (make-parameter "http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js"))
51(define enable-ajax (make-parameter #f))
52(define ajax-namespace (make-parameter "ajax"))
53(define enable-session (make-parameter #f))
54(define page-access-control (make-parameter (lambda (path) #t)))
55(define page-access-denied-message (make-parameter (lambda (path) (<h3> "Access denied."))))
56(define page-doctype (make-parameter ""))
57(define page-css (make-parameter #f))
58(define page-charset (make-parameter #f))
59(define login-page-path (make-parameter "/login")) ;; don't forget no-session: #t for this page
60(define main-page-path (make-parameter "/"))
61(define app-root-path (make-parameter "/"))
62(define valid-password? (make-parameter (lambda (user password) #f)))
63(define page-template (make-parameter html-page))
64(define ajax-invalid-session-message (make-parameter "Invalid session."))
65(define web-repl-access-control (make-parameter (lambda () #f)))
66(define web-repl-access-denied-message (make-parameter (<h3> "Access denied.")))
67(define session-inspector-access-control (make-parameter (lambda () #f)))
68(define session-inspector-access-denied-message (make-parameter (<h3> "Access denied.")))
69(define enable-javascript-compression (make-parameter #f))
70(define javascript-compressor (make-parameter identity))
71(define page-exception-message
72  (make-parameter
73   (lambda (exn)
74     (<h3> "An error has accurred while processing your request."))))
75(define debug-resources (make-parameter #f)) ;; usually usefule for awful development debugging
76
77;; Parameters for internal use
78(define http-request-variables (make-parameter #f))
79(define db-connection (make-parameter #f))
80(define page-javascript (make-parameter ""))
81(define sid (make-parameter #f))
82(define db-enabled? (make-parameter #f))
83
84;; db-support parameters (set by awful-<db> eggs)
85(define missing-db-msg "Database access is not enabled (see `enable-db').")
86(define db-inquirer (make-parameter (lambda (query) (error '$db missing-db-msg))))
87(define db-connect (make-parameter (lambda (credentials) (error 'db-connect missing-db-msg))))
88(define db-disconnect (make-parameter (lambda (connection) (error 'db-disconnect missing-db-msg))))
89(define sql-quoter (make-parameter (lambda args (error 'sql-quote missing-db-msg))))
90(define db-make-row-obj (make-parameter (lambda (q) (error '$db-row-obj missing-db-msg))))
91
92
93;;; Misc
94(define ++ string-append)
95
96(define (concat args #!optional (sep ""))
97  (string-intersperse (map ->string args) sep))
98
99(define (string->symbol* str)
100  (if (string? str)
101      (string->symbol str)
102      str))
103
104(define (load-apps apps)
105  (set! *resources* (make-hash-table equal?))
106  (for-each load apps))
107
108(define awful-start start-server)
109
110
111;;; Javascript
112(define (include-javascript file)
113  (<script> type: "text/javascript" src: file))
114
115(define (add-javascript . code)
116  (page-javascript (++ (page-javascript) (concat code))))
117
118(define (maybe-compress-javascript js no-javascript-compression)
119  (if (and (enable-javascript-compression)
120           (javascript-compressor)
121           (not no-javascript-compression))
122      (string-trim-both ((javascript-compressor) js))
123      js))
124
125
126;;; Debugging
127(define (debug . args)
128  (when (debug-file)
129    (with-output-to-file (debug-file)
130      (lambda ()
131        (print (concat args)))
132      append:)))
133
134(define (debug-pp arg)
135  (when (debug-file)
136    (with-output-to-file (debug-file) (cut pp arg) append:)))
137
138
139;;; Session access
140(define ($session var #!optional default)
141  (session-ref (sid) (string->symbol* var) default))
142
143(define ($session-set! var #!optional val)
144  (if (list? var)
145      (for-each (lambda (var/val)
146                  (session-set! (sid) (string->symbol* (car var/val)) (cdr var/val)))
147                var)
148      (session-set! (sid) (string->symbol* var) val)))
149
150(define (awful-refresh-session!)
151  (when (and (enable-session) (session-valid? (sid)))
152    (session-refresh! (sid))))
153
154
155;;; Session-aware procedures for HTML code generation
156(define (link url text . rest)
157  (let ((use-session? (and (sid)
158                           (session-valid? (sid))
159                           (not (get-keyword no-session: rest))))
160        (arguments (or (get-keyword arguments: rest) '()))
161        (separator (or (get-keyword separator: rest) ";&")))
162    (apply <a>
163           (append
164            (list href: (if url
165                            (++ url
166                                (if (or use-session? (not (null? arguments)))
167                                    (++ "?"
168                                        (form-urlencode
169                                         (append arguments
170                                                 (if use-session?
171                                                     `((sid . ,(sid)))
172                                                     '()))
173                                         separator: separator))
174                                    ""))
175                            "#"))
176            rest
177            (list text)))))
178
179(define (form contents . rest)
180  (let ((use-session? (and (sid)
181                           (session-valid? (sid))
182                           (not (get-keyword no-session: rest)))))
183    (apply <form>
184           (append rest
185                   (list
186                    (++ (if use-session?
187                            (hidden-input 'sid (sid))
188                            "")
189                        contents))))))
190
191
192;;; HTTP request variables access
193(define ($ var #!optional default/converter)
194  ((http-request-variables) var default/converter))
195
196
197;;; DB access
198(define ($db q #!key default values)
199  (debug-query q)
200  ((db-inquirer) q default: default values: values))
201
202(define (debug-query q)
203  (when (and (debug-file) (debug-db-query?))
204    (debug (++ (debug-db-query-prefix) q))))
205
206(define ($db-row-obj q)
207  (debug-query q)
208  ((db-make-row-obj) q))
209
210(define (sql-quote . data)
211  ((sql-quoter) data))
212
213
214;;; Resources
215(root-path (current-directory))
216
217(define *resources* (make-hash-table equal?))
218
219(define (register-dispatcher)
220  (handle-not-found
221   (let ((old-handler (handle-not-found)))
222     (lambda (_)
223       (let* ((path-list (uri-path (request-uri (current-request))))
224              (dir? (equal? (last path-list) ""))
225              (path (if (null? (cdr path-list))
226                        (car path-list)
227                        (++ "/" (concat (cdr path-list) "/"))))
228              (proc (resource-ref path (root-path))))
229         (if proc
230             (run-resource proc path)
231             (if dir? ;; try to find a procedure with the trailing slash removed
232                 (let ((proc (resource-ref (string-chomp path "/") (root-path))))
233                   (if proc
234                       (run-resource proc path)
235                       (old-handler _)))
236                 (old-handler _))))))))
237
238(define (run-resource proc path)
239  (let ((out (->string (proc path))))
240    (with-headers `((content-type text/html)
241                    (content-length ,(string-length out)))
242                  (lambda ()
243                    (write-logged-response)
244                    (unless (eq? 'HEAD (request-method (current-request)))
245                      (display out (response-port (current-response))))))))
246
247(define (resource-ref path vhost-root-path #!optional check-existence)
248  (when (debug-resources)
249    (debug-pp (hash-table->alist *resources*)))
250  (or (hash-table-ref/default *resources* (cons path vhost-root-path) #f)
251      (resource-match path vhost-root-path check-existence)))
252
253(define (resource-match path vhost-root-path #!optional check-existence)
254  ;; When `check-existence' is #f, `resource-match' will try to
255  ;; actually match the given path and the path from `*resources*',
256  ;; instead of just checking whether they are equal.
257  (let loop ((resources (hash-table->alist *resources*)))
258    (if (null? resources)
259        #f
260        (let* ((current-resource (car resources))
261               (current-path (caar current-resource))
262               (current-vhost (cdar current-resource))
263               (current-proc (cdr current-resource)))
264          (if (and (regexp? current-path)
265                   (equal? current-vhost vhost-root-path)
266                   (if check-existence
267                       (equal? current-path path)
268                       (string-match current-path path)))
269              current-proc
270              (loop (cdr resources)))))))
271
272(define (resource-exists? path vhost-root-path #!optional check-existence)
273  (not (not (resource-ref path vhost-root-path check-existence))))
274
275(define (add-resource! path vhost-root-path proc)
276  (unless (resource-exists? path vhost-root-path 'check-existence)
277    (hash-table-set! *resources* (cons path vhost-root-path) proc)))
278
279
280;;; Root dir
281(define (redirect-to dest)
282  (parameterize
283    ((current-response
284      (update-response
285       (current-response)
286       code: 302
287       headers: (headers `((location ,dest)
288                           (content-length 0))
289                         (response-headers (current-response))))))
290    (write-logged-response)))
291
292(define (register-root-dir-handler)
293  (handle-directory
294   (let ((old-handler (handle-directory)))
295     (lambda (path)
296       (cond ((resource-ref path (root-path))
297              => (cut run-resource <> path))
298             (else (old-handler path)))))))
299
300;;; Pages
301(define (define-page path contents #!key css title doctype headers charset no-ajax
302                     no-template no-session no-db vhost-root-path no-javascript-compression
303                     use-session) ;; for define-session-page
304  (##sys#check-closure contents 'define-page)
305  (let ((path (if (regexp? path)
306                  path
307                  (make-pathname (app-root-path) path))))
308    (add-resource!
309     path
310     (or vhost-root-path (root-path))
311     (lambda (#!optional given-path)
312       (http-request-variables (request-vars))
313       (sid ($ 'sid))
314       (when (and (db-credentials) (db-enabled?) (not no-db))
315         (db-connection ((db-connect) (db-credentials))))
316       (page-javascript "")
317       (awful-refresh-session!)
318       (let ((out
319              (if (or (not (enable-session))
320                      no-session
321                      use-session
322                      (and (enable-session) (session-valid? (sid))))
323                  (if ((page-access-control) path)
324                      (begin
325                        (when use-session
326                          (if (session-valid? (sid))
327                              (awful-refresh-session!)
328                              (sid (session-create))))
329                        (let ((contents
330                               (handle-exceptions
331                                exn
332                                (begin
333                                  (debug (with-output-to-string
334                                           (lambda ()
335                                             (print-call-chain)
336                                             (print-error-message exn))))
337                                  ((page-exception-message) exn))
338                                (if (regexp? path)
339                                    (contents given-path)
340                                    (contents)))))
341                          (if no-template
342                              contents
343                              ((page-template)
344                               contents
345                               css: (or css (page-css))
346                               title: title
347                               doctype: (or doctype (page-doctype))
348                               headers: (++ (if (or no-ajax (not (ajax-library)) (not (enable-ajax)))
349                                                ""
350                                                (<script> type: "text/javascript"
351                                                          src: (ajax-library)))
352                                            (or headers "")
353                                            (if (or no-ajax
354                                                    (not (enable-ajax))
355                                                    (not (ajax-library)))
356                                                (if (string-null? (page-javascript))
357                                                    ""
358                                                    (<script> type: "text/javascript"
359                                                              (maybe-compress-javascript
360                                                               (page-javascript)
361                                                               no-javascript-compression)))
362                                                (<script> type: "text/javascript"
363                                                          (maybe-compress-javascript
364                                                           (++ "$(document).ready(function(){"
365                                                               (page-javascript) "});")
366                                                           no-javascript-compression))))
367                               charset: (or charset (page-charset))))))
368                      ((page-template) ((page-access-denied-message) path)))
369                  ((page-template)
370                   ""
371                   headers: (<meta> http-equiv: "refresh"
372                                    content: (++ "0;url=" (login-page-path)
373                                                 "?reason=invalid-session&attempted-path=" path
374                                                 "&user=" ($ 'user "")
375                                                 (if ($ 'sid) (++ "&sid=" ($ 'sid)) "")))))))
376         (when (and (db-connection) (db-enabled?) (not no-db)) ((db-disconnect) (db-connection)))
377         out)))))
378
379(define (define-session-page path contents . rest)
380  ;; `rest' are same keyword params as for `define-page' (except `no-session', obviously)
381  (apply define-page (append (list path contents) (list use-session: #t) rest)))
382
383
384;;; Ajax
385(define (ajax path id event proc #!key target (action 'html) (method 'POST) (arguments '())
386              js no-session no-db no-page-javascript vhost-root-path live content-type prelude update-targets)
387  (if (enable-ajax)
388      (let ((path (if (regexp? path)
389                  path
390                  (make-pathname (list (app-root-path) (ajax-namespace)) path))))
391        (add-resource! path
392                       (or vhost-root-path (root-path))
393                       (lambda (#!optional given-path)
394                         (http-request-variables (request-vars))
395                         (sid ($ 'sid))
396                         (when (and (db-credentials) (db-enabled?) (not no-db))
397                           (db-connection ((db-connect) (db-credentials))))
398                         (awful-refresh-session!)
399                         (if (or (not (enable-session))
400                                 no-session
401                                 (and (enable-session) (session-valid? (sid))))
402                             (if ((page-access-control) path)
403                                 (let ((out (if update-targets
404                                                (with-output-to-string
405                                                  (lambda ()
406                                                    (json-write (list->vector (proc)))))
407                                                (proc))))
408                                   (when (and (db-credentials) (db-enabled?) (not no-db))
409                                     ((db-disconnect) (db-connection)))
410                                   out)
411                                 ((page-access-denied-message) path))
412                             (ajax-invalid-session-message))))
413        (let* ((arguments (if (or (not (enable-session))
414                                  no-session
415                                  (not (and (sid) (session-valid? (sid)))))
416                              arguments
417                              (cons `(sid . ,(++ "'" (sid) "'")) arguments)))
418               (js-code
419                (++ (page-javascript)
420                    (if (and id event)
421                        (let ((events (concat (if (list? event) event (list event)) " "))
422                              (binder (if live "live" "bind")))
423                          (++ "$('" (if (symbol? id)
424                                        (conc "#" id)
425                                        id)
426                              "')." binder "('" events "',"))
427                        "")
428                    (++ "function(){"
429                        (or prelude "")
430                        "$.ajax({type:'" (->string method) "',"
431                        "url:'" path "',"
432                        (if content-type
433                            (conc "contentType: '" content-type "',")
434                            "")
435                        "success:function(response){"
436                        (if update-targets
437                            "$.each(response, function(id, html) { $('#' + id).html(html);});"
438                            (or js
439                                (if target
440                                    (++ "$('#" target "')." (->string action) "(response);")
441                                    "return;")))
442                        "},"
443                        (if update-targets
444                            "dataType: 'json',"
445                            "")
446                        (++ "data:{"
447                            (string-intersperse
448                             (map (lambda (var/val)
449                                    (conc  "'" (car var/val) "':" (cdr var/val)))
450                                  arguments)
451                             ",") "}")
452                        "})}")
453                    (if (and id event)
454                        ");\n"
455                        ""))))
456          (unless no-page-javascript (page-javascript js-code))
457          js-code))
458      "")) ;; empty if no-ajax
459
460(define (periodical-ajax path interval proc #!key target (action 'html) (method 'POST)
461                         (arguments '()) js no-session no-db vhost-root-path live
462                         content-type prelude update-targets)
463  (if (enable-ajax)
464      (page-javascript
465       (++ "setInterval("
466           (ajax path #f #f proc
467                 target: target
468                 action: action
469                 method: method
470                 arguments: arguments
471                 js: js
472                 no-session: no-session
473                 no-db: no-db
474                 vhost-root-path: vhost-root-path
475                 live: live
476                 content-type: content-type
477                 prelude: prelude
478                 update-targets: update-targets
479                 no-page-javascript: #t)
480           ", " (->string interval) ");\n"))
481      ""))
482
483(define (ajax-link path id text proc #!key target (action 'html) (method 'POST) (arguments '())
484                   js no-session no-db (event 'click) vhost-root-path live class
485                   hreflang type rel rev charset coords shape accesskey tabindex a-target
486                   content-type prelude update-targets)
487  (ajax path id event proc
488        target: target
489        action: action
490        method: method
491        arguments: arguments
492        js: js
493        no-session: no-session
494        vhost-root-path: vhost-root-path
495        live: live
496        content-type: content-type
497        prelude: prelude
498        update-targets: update-targets
499        no-db: no-db)
500  (<a> href: "#"
501       id: id
502       class: class
503       hreflang: hreflang
504       type: type
505       rel: rel
506       rev: rev
507       charset: charset
508       coords: coords
509       shape: shape
510       accesskey: accesskey
511       tabindex: tabindex
512       target: a-target
513       text))
514
515
516;;; Login form
517(define (login-form #!key (user-label "User: ")
518                          (password-label "Password: ")
519                          (submit-label "Submit")
520                          (trampoline-path "/login-trampoline")
521                          (refill-user #t))
522  (let ((attempted-path ($ 'attempted-path))
523        (user ($ 'user)))
524    (<form> action: trampoline-path method: "post"
525            (if attempted-path
526                (hidden-input 'attempted-path attempted-path)
527                "")
528            (<span> id: "user-container"
529                    (<span> id: "user-label" user-label)
530                    (<input> type: "text" id: "user" name: "user" value: (and refill-user user)))
531            (<span> id: "password-container"
532                    (<span> id: "password-label" password-label)
533                    (<input> type: "password" id: "password" name: "password"))
534            (<input> type: "submit" id: "login-submit" value: submit-label))))
535
536
537;;; Login trampoline (for redirection)
538(define (define-login-trampoline path #!key vhost-root-path hook)
539  (define-page path
540    (lambda ()
541      (let* ((user ($ 'user))
542             (password ($ 'password))
543             (attempted-path ($ 'attempted-path))
544             (password-valid? ((valid-password?) user password))
545             (new-sid (and password-valid? (session-create))))
546        (sid new-sid)
547        (when hook (hook user))
548        (html-page
549         ""
550         headers: (<meta> http-equiv: "refresh"
551                          content: (++ "0;url="
552                                       (if new-sid
553                                           (++ (or attempted-path (main-page-path)) "?user=" user "&sid=" new-sid)
554                                           (++ (login-page-path) "?reason=invalid-password&user=" user)))))))
555    vhost-root-path: vhost-root-path
556    no-session: #t
557    no-template: #t))
558
559
560;;; Web repl
561(define (enable-web-repl path #!key css title)
562  (enable-ajax #t)
563  (define-page path
564    (lambda ()
565      (if ((web-repl-access-control))
566          (let ((web-eval
567                 (lambda ()
568                   (<pre> convert-to-entities?: #t
569                          (with-output-to-string
570                            (lambda ()
571                              (pp (handle-exceptions
572                                   exn
573                                   (begin
574                                     (print-error-message exn)
575                                     (print-call-chain))
576                                   (eval `(begin
577                                            ,@(with-input-from-string ($ 'code "")
578                                                read-file)))))))))))
579            (page-javascript "$('#clear').click(function(){$('#prompt').val('');});")
580            (ajax (++ path "-eval") 'eval 'click web-eval
581                  target: "result"
582                  arguments: '((code . "$('#prompt').val()")))
583
584            (++ (<textarea> id: "prompt" name: "prompt" rows: "6" cols: "90")
585                (itemize
586                 (map (lambda (item)
587                        (<a> href: "#" id: (car item) (cdr item)))
588                      '(("eval"  . "Eval")
589                        ("clear" . "Clear")))
590                 list-id: "button-bar")
591                (<div> id: "result")))
592          (web-repl-access-denied-message)))
593    title: (or title "Web REPL")
594    css: css))
595
596
597;;; Session inspector
598(define (enable-session-inspector path #!key css title)
599  (enable-session #t)
600  (define-page path
601    (lambda ()
602      (if ((session-inspector-access-control))
603          (let ((bindings (session-bindings (sid))))
604            (if (null? bindings)
605                (<h2> "Session for sid " (sid) " is empty")
606                (++ (<h2> "Session for " (sid))
607                    (tabularize
608                     (map (lambda (binding)
609                            (let ((var (car binding))
610                                  (val (with-output-to-string
611                                         (lambda ()
612                                           (pp (cdr binding))))))
613                              (list var (<pre> val))))
614                          bindings)))))
615          (session-inspector-access-denied-message)))
616    title: (or title "Session inspector")
617    css: css))
618
619) ; end module
Note: See TracBrowser for help on using the repository browser.