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

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

awful.scm (trunk): whitespace-cleanup

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