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

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

awful: require the regex egg. Version bumped to 0.27.0

File size: 34.8 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 awful-response-headers
14   development-mode? enable-web-repl-fancy-editor web-repl-fancy-editor-base-uri
15
16   ;; Procedures
17   ++ concat include-javascript add-javascript debug debug-pp $session
18   $session-set! $ $db $db-row-obj sql-quote define-page undefine-page
19   define-session-page ajax ajax-link periodical-ajax login-form
20   define-login-trampoline enable-web-repl enable-session-inspector
21   awful-version load-apps link form redirect-to
22
23   ;; Required by the awful server
24   add-resource! register-dispatcher register-root-dir-handler awful-start
25
26   ;; Required by db-support eggs
27   db-enabled? db-inquirer db-connect db-disconnect sql-quoter db-make-row-obj
28
29  ) ; end export list
30
31(import scheme chicken data-structures utils extras ports srfi-69 files srfi-1)
32
33;; Units
34(use posix srfi-13)
35
36;; Eggs
37(use intarweb spiffy spiffy-request-vars html-tags html-utils uri-common
38     http-session json spiffy-cookies regex)
39
40;;; Version
41(define (awful-version) "0.27.0")
42
43
44;;; Parameters
45
46;; User-configurable parameters
47(define awful-apps (make-parameter '()))
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 "/"))
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 identity))
73(define awful-response-headers (make-parameter #f))
74(define development-mode? (make-parameter #f))
75(define enable-web-repl-fancy-editor (make-parameter #t))
76(define web-repl-fancy-editor-base-uri (make-parameter "http://parenteses.org/awful/codemirror"))
77(define page-exception-message
78  (make-parameter
79   (lambda (exn)
80     (<h3> "An error has accurred while processing your request."))))
81(define debug-resources (make-parameter #f)) ;; usually useful for awful development debugging
82(define enable-session-cookie (make-parameter #t))
83(define session-cookie-name (make-parameter "awful-cookie"))
84
85;; Parameters for internal use (but exported, since they are internally used by other eggs)
86(define http-request-variables (make-parameter #f))
87(define db-connection (make-parameter #f))
88(define page-javascript (make-parameter ""))
89(define sid (make-parameter #f))
90(define db-enabled? (make-parameter #f))
91
92;; Parameters for internal use and not exported
93(define %redirect (make-parameter #f))
94(define %web-repl-path (make-parameter #f))
95(define %session-inspector-path (make-parameter #f))
96(define %error (make-parameter #f))
97
98;; db-support parameters (set by awful-<db> eggs)
99(define missing-db-msg "Database access is not enabled (see `enable-db').")
100(define db-inquirer (make-parameter (lambda (query) (error '$db missing-db-msg))))
101(define db-connect (make-parameter (lambda (credentials) (error 'db-connect missing-db-msg))))
102(define db-disconnect (make-parameter (lambda (connection) (error 'db-disconnect missing-db-msg))))
103(define sql-quoter (make-parameter (lambda args (error 'sql-quote missing-db-msg))))
104(define db-make-row-obj (make-parameter (lambda (q) (error '$db-row-obj missing-db-msg))))
105
106
107;;; Misc
108(define ++ string-append)
109
110(define (concat args #!optional (sep ""))
111  (string-intersperse (map ->string args) sep))
112
113(define (string->symbol* str)
114  (if (string? str)
115      (string->symbol str)
116      str))
117
118(define (load-apps apps)
119  (set! *resources* (make-hash-table equal?))
120  (when (development-mode?) (development-mode-actions))
121  (for-each load apps))
122
123(define (define-reload-page)
124  ;; Define a /reload page for reloading awful apps
125  (define-page "/reload"
126    (lambda ()
127      (load-apps (awful-apps))
128      (++ (<p> "The following awful apps have been reloaded on "
129               (seconds->string (current-seconds)))
130          (itemize (map <code> (awful-apps)))))
131    no-ajax: #t
132    title: "Awful reloaded applications"))
133
134(define (development-mode-actions)
135  (development-mode? #t)
136  (print "Awful is running in development mode.")
137  (debug-log (current-error-port))
138
139  ;; Print the call chain, the error message and links to the
140  ;; web-repl and session-inspector (if enabled)
141  (page-exception-message
142   (lambda (exn)
143     (++ (<pre> convert-to-entities?: #t
144                (with-output-to-string
145                  (lambda ()
146                    (print-call-chain)
147                    (print-error-message exn))))
148         (<p> "[" (<a> href: (or (%web-repl-path) "/web-repl") "Web REPL") "]"
149              (if (enable-session)
150                  (++ " [" (<a> href: (or (%session-inspector-path) "/session-inspector")
151                                "Session inspector") "]")
152                  "")))))
153
154  ;; If web-repl has not been activated, activate it allowing access
155  ;; to the localhost at least (`web-repl-access-control' can be
156  ;; used to provide more permissive control)
157  (unless (%web-repl-path)
158    (let ((old-access-control (web-repl-access-control)))
159      (web-repl-access-control
160       (lambda ()
161         (or (old-access-control)
162             (equal? (remote-address) "127.0.0.1")))))
163    (enable-web-repl "/web-repl"))
164
165  ;; If session-inspector has not been activated, and if
166  ;; `enable-session' is #t, activate it allowing access to the
167  ;; localhost at least (`session-inspector-access-control' can be
168  ;; used to provide more permissive control)
169  (when (and (enable-session) (not (%session-inspector-path)))
170    (let ((old-access-control (session-inspector-access-control)))
171      (session-inspector-access-control
172       (lambda ()
173         (or (old-access-control)
174             (equal? (remote-address) "127.0.0.1"))))
175      (enable-session-inspector "/session-inspector")))
176
177  ;; The reload page
178  (define-reload-page))
179
180(define (awful-start #!key dev-mode? port ip-address use-fancy-web-repl?)
181  (enable-web-repl-fancy-editor use-fancy-web-repl?)
182  (when dev-mode? (development-mode-actions))
183  ;; Start Spiffy
184  (start-server port: (or port (server-port))
185                bind-address: (or ip-address (server-bind-address))))
186
187(define (get-sid #!optional force-read-sid)
188  (and (or (enable-session) force-read-sid)
189       (if (enable-session-cookie)
190           (or (read-cookie (session-cookie-name)) ($ 'sid))
191           ($ 'sid))))
192
193(define (redirect-to new-uri)
194  ;; Just set the `%redirect' internal parameter, so `run-resource' is
195  ;; able to know where to redirect.
196  (%redirect new-uri))
197
198
199;;; Javascript
200(define (include-javascript . files)
201  (string-intersperse
202   (map (lambda (file)
203          (<script> type: "text/javascript" src: file))
204        files)))
205
206(define (add-javascript . code)
207  (page-javascript (++ (page-javascript) (concat code))))
208
209(define (maybe-compress-javascript js no-javascript-compression)
210  (if (and (enable-javascript-compression)
211           (javascript-compressor)
212           (not no-javascript-compression))
213      (string-trim-both ((javascript-compressor) js))
214      js))
215
216
217;;; Debugging
218(define (debug . args)
219  (when (debug-file)
220    (with-output-to-file (debug-file)
221      (lambda ()
222        (print (concat args)))
223      append:)))
224
225(define (debug-pp arg)
226  (when (debug-file)
227    (with-output-to-file (debug-file) (cut pp arg) append:)))
228
229
230;;; Session access
231(define ($session var #!optional default)
232  (session-ref (sid) (string->symbol* var) default))
233
234(define ($session-set! var #!optional val)
235  (if (list? var)
236      (for-each (lambda (var/val)
237                  (session-set! (sid) (string->symbol* (car var/val)) (cdr var/val)))
238                var)
239      (session-set! (sid) (string->symbol* var) val)))
240
241(define (awful-refresh-session!)
242  (when (and (enable-session) (session-valid? (sid)))
243    (session-refresh! (sid))))
244
245
246;;; Session-aware procedures for HTML code generation
247(define (link url text . rest)
248  (let ((pass-sid? (and (not (enable-session-cookie))
249                        (sid)
250                        (session-valid? (sid))
251                        (not (get-keyword no-session: rest))))
252        (arguments (or (get-keyword arguments: rest) '()))
253        (separator (or (get-keyword separator: rest) ";&")))
254    (apply <a>
255           (append
256            (list href: (if url
257                            (++ url
258                                (if (or pass-sid? (not (null? arguments)))
259                                    (++ "?"
260                                        (form-urlencode
261                                         (append arguments
262                                                 (if pass-sid?
263                                                     `((sid . ,(sid)))
264                                                     '()))
265                                         separator: separator))
266                                    ""))
267                            "#"))
268            rest
269            (list text)))))
270
271(define (form contents . rest)
272  (let ((pass-sid? (and (not (enable-session-cookie))
273                        (sid)
274                        (session-valid? (sid))
275                        (not (get-keyword no-session: rest)))))
276    (apply <form>
277           (append rest
278                   (list
279                    (++ (if pass-sid?
280                            (hidden-input 'sid (sid))
281                            "")
282                        contents))))))
283
284
285;;; HTTP request variables access
286(define ($ var #!optional default/converter)
287  (unless (http-request-variables)
288    (http-request-variables (request-vars)))
289  ((http-request-variables) var default/converter))
290
291
292;;; DB access
293(define ($db q #!key default values)
294  (debug-query q)
295  ((db-inquirer) q default: default values: values))
296
297(define (debug-query q)
298  (when (and (debug-file) (debug-db-query?))
299    (debug (++ (debug-db-query-prefix) q))))
300
301(define ($db-row-obj q)
302  (debug-query q)
303  ((db-make-row-obj) q))
304
305(define (sql-quote . data)
306  ((sql-quoter) data))
307
308
309;;; Resources
310(root-path (current-directory))
311
312(define *resources* (make-hash-table equal?))
313
314(define (register-dispatcher)
315  (handle-not-found
316   (let ((old-handler (handle-not-found)))
317     (lambda (_)
318       (let* ((path-list (uri-path (request-uri (current-request))))
319              (dir? (equal? (last path-list) ""))
320              (path (if (null? (cdr path-list))
321                        (car path-list)
322                        (++ "/" (concat (cdr path-list) "/"))))
323              (proc (resource-ref path (root-path))))
324         (if proc
325             (run-resource proc path)
326             (if dir? ;; try to find a procedure with the trailing slash removed
327                 (let ((proc (resource-ref (string-chomp path "/") (root-path))))
328                   (if proc
329                       (run-resource proc path)
330                       (old-handler _)))
331                 (old-handler _))))))))
332
333(define (run-resource proc path)
334  (let ((out (->string (proc path))))
335    (if (%error)
336        (send-response code: 500
337                       reason: "Internal server error"
338                       body: ((page-template) ((page-exception-message) (%error)))
339                       headers: '((content-type text/html)))
340        (if (%redirect) ;; redirection
341            (let ((new-uri (if (string? (%redirect))
342                               (uri-reference (%redirect))
343                               (%redirect))))
344              (with-headers `((location ,new-uri))
345                            (lambda ()
346                              (%redirect #f)
347                              (send-status 302 "Found"))))
348            (with-headers (append
349                           (or (awful-response-headers)
350                               `((content-type text/html)))
351                           (or (and-let* ((headers (awful-response-headers))
352                                          (content-length (alist-ref 'content-length headers)))
353                                 (list (cons 'content-length content-length)))
354                               `((content-length ,(string-length out)))))
355                          (lambda ()
356                            (write-logged-response)
357                            (unless (eq? 'HEAD (request-method (current-request)))
358                              (display out (response-port (current-response))))))))))
359
360(define (resource-ref path vhost-root-path)
361  (when (debug-resources)
362    (debug-pp (hash-table->alist *resources*)))
363  (or (hash-table-ref/default *resources* (cons path vhost-root-path) #f)
364      (resource-match path vhost-root-path)))
365
366(define (resource-match path vhost-root-path)
367  (let loop ((resources (hash-table->alist *resources*)))
368    (if (null? resources)
369        #f
370        (let* ((current-resource (car resources))
371               (current-path (caar current-resource))
372               (current-vhost (cdar current-resource))
373               (current-proc (cdr current-resource)))
374          (if (and (regexp? current-path)
375                   (equal? current-vhost vhost-root-path)
376                   (string-match current-path path))
377              current-proc
378              (loop (cdr resources)))))))
379
380(define (add-resource! path vhost-root-path proc)
381  (hash-table-set! *resources* (cons path vhost-root-path) proc))
382
383
384;;; Root dir
385(define (register-root-dir-handler)
386  (handle-directory
387   (let ((old-handler (handle-directory)))
388     (lambda (path)
389       (cond ((resource-ref path (root-path))
390              => (cut run-resource <> path))
391             (else (old-handler path)))))))
392
393;;; Pages
394(define (undefine-page path #!optional vhost-root-path)
395  (hash-table-delete! *resources* (cons path (or vhost-root-path (root-path)))))
396
397(define (define-page path contents #!key css title doctype headers charset no-ajax
398                     no-template no-session no-db vhost-root-path no-javascript-compression
399                     use-ajax use-session) ;; for define-session-page
400  (##sys#check-closure contents 'define-page)
401  (let ((path (if (regexp? path)
402                  path
403                  (make-pathname (app-root-path) path))))
404    (add-resource!
405     path
406     (or vhost-root-path (root-path))
407     (lambda (#!optional given-path)
408       (sid (get-sid))
409       (when (and (db-credentials) (db-enabled?) (not no-db))
410         (db-connection ((db-connect) (db-credentials))))
411       (page-javascript "")
412       (awful-refresh-session!)
413       (let ((out
414              (if (or (not (enable-session))
415                      no-session
416                      use-session
417                      (and (enable-session) (session-valid? (sid))))
418                  (if ((page-access-control) (or given-path path))
419                      (begin
420                        (when use-session
421                          (if (session-valid? (sid))
422                              (awful-refresh-session!)
423                              (begin
424                                (sid (session-create))
425                                (set-cookie! (session-cookie-name) (sid)))))
426                        (let ((contents
427                               (handle-exceptions
428                                exn
429                                (begin
430                                  (%error exn)
431                                  (debug (with-output-to-string
432                                           (lambda ()
433                                             (print-call-chain)
434                                             (print-error-message exn))))
435                                  ((page-exception-message) exn))
436                                (if (regexp? path)
437                                    (contents given-path)
438                                    (contents))))
439                              (ajax? (cond (no-ajax #f)
440                                           ((not (ajax-library)) #f)
441                                           ((and (ajax-library) use-ajax) #t)
442                                           ((enable-ajax) #t)
443                                           (else #f))))
444                          (http-request-variables #f)
445                          (if (%redirect)
446                              #f ;; no need to do anything.  Let `run-resource' perform the redirection
447                              (if no-template
448                                  contents
449                                  ((page-template)
450                                   contents
451                                   css: (or css (page-css))
452                                   title: title
453                                   doctype: (or doctype (page-doctype))
454                                   headers: (++ (if ajax?
455                                                    (<script> type: "text/javascript"
456                                                              src: (ajax-library))
457                                                    "")
458                                                (or headers "")
459                                                (if ajax?
460                                                    (<script> type: "text/javascript"
461                                                              (maybe-compress-javascript
462                                                               (++ "$(document).ready(function(){"
463                                                                   (page-javascript) "});")
464                                                               no-javascript-compression))
465                                                    (if (string-null? (page-javascript))
466                                                        ""
467                                                        (<script> type: "text/javascript"
468                                                                  (maybe-compress-javascript
469                                                                   (page-javascript)
470                                                                   no-javascript-compression)))))
471                               charset: (or charset (page-charset)))))))
472                      ((page-template) ((page-access-denied-message) (or given-path path))))
473                  ((page-template)
474                   ""
475                   headers: (<meta> http-equiv: "refresh"
476                                    content: (++ "0;url=" (login-page-path)
477                                                 "?reason=invalid-session&attempted-path=" (or given-path path)
478                                                 "&user=" ($ 'user "")
479                                                 (if (and (not (enable-session-cookie)) ($ 'sid))
480                                                     (++ "&sid=" ($ 'sid))
481                                                     "")))))))
482         (when (and (db-connection) (db-enabled?) (not no-db)) ((db-disconnect) (db-connection)))
483         out))))
484  path)
485
486(define (define-session-page path contents . rest)
487  ;; `rest' are same keyword params as for `define-page' (except `no-session', obviously)
488  (apply define-page (append (list path contents) (list use-session: #t) rest)))
489
490
491;;; Ajax
492(define (ajax path id event proc #!key (action 'html) (method 'POST) (arguments '())
493              target success no-session no-db no-page-javascript vhost-root-path
494              live content-type prelude update-targets)
495  (let ((path (if (regexp? path)
496                  path
497                  (make-pathname (list (app-root-path) (ajax-namespace)) path))))
498    (add-resource! path
499                   (or vhost-root-path (root-path))
500                   (lambda (#!optional given-path)
501                     (sid (get-sid))
502                     (when (and (db-credentials) (db-enabled?) (not no-db))
503                       (db-connection ((db-connect) (db-credentials))))
504                     (awful-refresh-session!)
505                     (if (or (not (enable-session))
506                             no-session
507                             (and (enable-session) (session-valid? (sid))))
508                         (if ((page-access-control) path)
509                             (let ((out (if update-targets
510                                            (with-output-to-string
511                                              (lambda ()
512                                                (json-write (list->vector (proc)))))
513                                            (proc))))
514                               (when (and (db-credentials) (db-enabled?) (not no-db))
515                                 ((db-disconnect) (db-connection)))
516                               out)
517                             ((page-access-denied-message) path))
518                         (ajax-invalid-session-message))))
519    (let* ((arguments (if (or (not (enable-session-cookie))
520                              (not (enable-session))
521                              no-session
522                              (not (and (sid) (session-valid? (sid)))))
523                          arguments
524                          (cons `(sid . ,(++ "'" (sid) "'")) arguments)))
525           (js-code
526            (++ (page-javascript)
527                (if (and id event)
528                    (let ((events (concat (if (list? event) event (list event)) " "))
529                          (binder (if live "live" "bind")))
530                      (++ "$('" (if (symbol? id)
531                                    (conc "#" id)
532                                    id)
533                          "')." binder "('" events "',"))
534                    "")
535                (++ "function(){"
536                    (or prelude "")
537                    "$.ajax({type:'" (->string method) "',"
538                    "url:'" path "',"
539                    (if content-type
540                        (conc "contentType: '" content-type "',")
541                        "")
542                    "success:function(response){"
543                    (or success
544                        (cond (update-targets
545                               "$.each(response, function(id, html) { $('#' + id).html(html);});")
546                              (target
547                               (++ "$('#" target "')." (->string action) "(response);"))
548                              (else "return;")))
549                    "},"
550                    (if update-targets
551                        "dataType: 'json',"
552                        "")
553                    (++ "data:{"
554                        (string-intersperse
555                         (map (lambda (var/val)
556                                (conc  "'" (car var/val) "':" (cdr var/val)))
557                              arguments)
558                         ",") "}")
559                    "})}")
560                (if (and id event)
561                    ");\n"
562                    ""))))
563      (unless no-page-javascript (page-javascript js-code))
564      (http-request-variables #f)
565      js-code)))
566
567(define (periodical-ajax path interval proc #!key target (action 'html) (method 'POST)
568                         (arguments '()) success no-session no-db vhost-root-path live
569                         content-type prelude update-targets)
570  (if (enable-ajax)
571      (page-javascript
572       (++ "setInterval("
573           (ajax path #f #f proc
574                 target: target
575                 action: action
576                 method: method
577                 arguments: arguments
578                 success: success
579                 no-session: no-session
580                 no-db: no-db
581                 vhost-root-path: vhost-root-path
582                 live: live
583                 content-type: content-type
584                 prelude: prelude
585                 update-targets: update-targets
586                 no-page-javascript: #t)
587           ", " (->string interval) ");\n"))
588      ""))
589
590(define (ajax-link path id text proc #!key target (action 'html) (method 'POST) (arguments '())
591                   success no-session no-db (event 'click) vhost-root-path live class
592                   hreflang type rel rev charset coords shape accesskey tabindex a-target
593                   content-type prelude update-targets)
594  (ajax path id event proc
595        target: target
596        action: action
597        method: method
598        arguments: arguments
599        success: success
600        no-session: no-session
601        vhost-root-path: vhost-root-path
602        live: live
603        content-type: content-type
604        prelude: prelude
605        update-targets: update-targets
606        no-db: no-db)
607  (<a> href: "#"
608       id: id
609       class: class
610       hreflang: hreflang
611       type: type
612       rel: rel
613       rev: rev
614       charset: charset
615       coords: coords
616       shape: shape
617       accesskey: accesskey
618       tabindex: tabindex
619       target: a-target
620       text))
621
622
623;;; Login form
624(define (login-form #!key (user-label "User: ")
625                          (password-label "Password: ")
626                          (submit-label "Submit")
627                          (trampoline-path "/login-trampoline")
628                          (refill-user #t))
629  (let ((attempted-path ($ 'attempted-path))
630        (user ($ 'user)))
631    (<form> action: trampoline-path method: "post"
632            (if attempted-path
633                (hidden-input 'attempted-path attempted-path)
634                "")
635            (<span> id: "user-container"
636                    (<span> id: "user-label" user-label)
637                    (<input> type: "text" id: "user" name: "user" value: (and refill-user user)))
638            (<span> id: "password-container"
639                    (<span> id: "password-label" password-label)
640                    (<input> type: "password" id: "password" name: "password"))
641            (<input> type: "submit" id: "login-submit" value: submit-label))))
642
643
644;;; Login trampoline (for redirection)
645(define (define-login-trampoline path #!key vhost-root-path hook)
646  (define-page path
647    (lambda ()
648      (let* ((user ($ 'user))
649             (password ($ 'password))
650             (attempted-path ($ 'attempted-path))
651             (password-valid? ((valid-password?) user password))
652             (new-sid (and password-valid? (session-create))))
653        (sid new-sid)
654        (when (enable-session-cookie)
655          (set-cookie! (session-cookie-name) new-sid))
656        (when hook (hook user))
657        (html-page
658         ""
659         headers: (<meta> http-equiv: "refresh"
660                          content: (++ "0;url="
661                                       (if new-sid
662                                           (++ (or attempted-path (main-page-path))
663                                               "?user=" user
664                                               (if (enable-session-cookie)
665                                                   ""
666                                                   (++ "&sid=" new-sid)))
667                                           (++ (login-page-path) "?reason=invalid-password&user=" user)))))))
668    vhost-root-path: vhost-root-path
669    no-session: #t
670    no-template: #t))
671
672
673;;; Web repl
674(define (enable-web-repl path #!key css (title "Awful Web REPL") headers)
675  (unless (development-mode?) (%web-repl-path path))
676  (define-page path
677    (lambda ()
678      (if ((web-repl-access-control))
679          (let ((web-eval
680                 (lambda ()
681                   (<pre> convert-to-entities?: #t
682                          (with-output-to-string
683                            (lambda ()
684                              (pp (handle-exceptions
685                                   exn
686                                   (begin
687                                     (print-error-message exn)
688                                     (print-call-chain))
689                                   (eval `(begin
690                                            ,@(with-input-from-string ($ 'code "")
691                                                read-file)))))))))))
692            (page-javascript
693             (++ "$('#clear').click(function(){"
694                 (if (enable-web-repl-fancy-editor)
695                     "editor.setCode('');"
696                     "$('#prompt').val('');")
697                 "});"))
698
699            (ajax (++ path "-eval") 'eval 'click web-eval
700                  target: "result"
701                  arguments: `((code . ,(if (enable-web-repl-fancy-editor)
702                                            "editor.getCode()"
703                                            "$('#prompt').val()"))))
704
705            (when (enable-web-repl-fancy-editor)
706              (ajax (++ path "-eval") 'eval-region 'click web-eval
707                    target: "result"
708                    arguments: `((code . "editor.selection()"))))
709
710            (++ (<h1> title)
711                (<h2> "Input area")
712                (let ((prompt (<textarea> id: "prompt" name: "prompt" rows: "10" cols: "90")))
713                  (if (enable-web-repl-fancy-editor)
714                      (<div> class: "border" prompt)
715                      prompt))
716                (itemize
717                 (map (lambda (item)
718                        (<button> id: (car item) (cdr item)))
719                      (append '(("eval"  . "Eval"))
720                              (if (enable-web-repl-fancy-editor)
721                                  '(("eval-region" . "Eval region"))
722                                  '())
723                              '(("clear" . "Clear"))))
724                 list-id: "button-bar")
725                (<h2> "Output area")
726                (<div> id: "result")
727                (if (enable-web-repl-fancy-editor)
728                    (<script> type: "text/javascript" "
729  function addClass(element, className) {
730    if (!editor.win.hasClass(element, className)) {
731      element.className = ((element.className.split(' ')).concat([className])).join(' ');}}
732
733  function removeClass(element, className) {
734    if (editor.win.hasClass(element, className)) {
735      var classes = element.className.split(' ');
736      for (var i = classes.length - 1 ; i >= 0; i--) {
737        if (classes[i] === className) {
738            classes.splice(i, 1)}}
739      element.className = classes.join(' ');}}
740
741  var textarea = document.getElementById('prompt');
742  var editor = new CodeMirror(CodeMirror.replace(textarea), {
743    height: '250px',
744    width: '600px',
745    content: textarea.value,
746    parserfile: ['" (web-repl-fancy-editor-base-uri) "/tokenizescheme.js',
747                 '" (web-repl-fancy-editor-base-uri) "/parsescheme.js'],
748    stylesheet:  '" (web-repl-fancy-editor-base-uri) "/schemecolors.css',
749    autoMatchParens: true,
750    path: '" (web-repl-fancy-editor-base-uri) "/',
751    disableSpellcheck: true,
752    markParen: function(span, good) {addClass(span, good ? 'good-matching-paren' : 'bad-matching-paren');},
753    unmarkParen: function(span) {removeClass(span, 'good-matching-paren'); removeClass(span, 'bad-matching-paren');}
754  });")
755                    "")))
756          (web-repl-access-denied-message)))
757    headers: (++ (if (enable-web-repl-fancy-editor)
758                     (include-javascript (make-pathname (web-repl-fancy-editor-base-uri) "codemirror.js")
759                                         (make-pathname (web-repl-fancy-editor-base-uri) "mirrorframe.js"))
760                     "")
761                 (let ((builtin-css (if css
762                                        #f
763                                        (<style> type: "text/css"
764"h1 { font-size: 18pt; background-color: #898E79; width: 590px; color: white; padding: 5px;}
765h2 { font-size: 14pt; background-color: #898E79; width: 590px; color: white; padding: 5px;}
766ul#button-bar { margin-left: 0; padding-left: 0; }
767#button-bar li {display: inline; list-style-type: none; padding-right: 10px; }"
768(if (enable-web-repl-fancy-editor)
769    "div.border { border: 1px solid black; width: 600px;}"
770    "#prompt { width: 600px; }")
771"#result { border: 1px solid #333; padding: 5px; width: 590px; }"))))
772                   (if headers
773                       (++ (or builtin-css "") headers)
774                       builtin-css)))
775    use-ajax: #t
776    title: title
777    css: css))
778
779
780;;; Session inspector
781(define (enable-session-inspector path #!key css (title "Awful session inspector") headers)
782  (unless (development-mode?) (%session-inspector-path path))
783  (define-page path
784    (lambda ()
785      (parameterize ((enable-session #t))
786        (if ((session-inspector-access-control))
787            (let ((bindings (session-bindings (sid))))
788              (++ (<h1> title)
789                  (if (null? bindings)
790                      (<p> "Session for sid " (sid) " is empty")
791                      (++ (<p> "Session for " (sid))
792                          (tabularize
793                           (map (lambda (binding)
794                                  (let ((var (car binding))
795                                        (val (with-output-to-string
796                                               (lambda ()
797                                                 (pp (cdr binding))))))
798                                    (list (<span> class: "session-inspector-var" var)
799                                          (<pre> convert-to-entities?: #t
800                                                 class: "session-inspector-value"
801                                                 val))))
802                                bindings)
803                           header: '("Variables" "Values")
804                           table-id: "session-inspector-table")))))
805            (session-inspector-access-denied-message))))
806    headers: (let ((builtin-css (if css
807                                    #f
808                                    (<style> type: "text/css"
809"h1 { font-size: 16pt; background-color: #898E79; width: 590px; color: white; padding: 5px;}
810.session-inspector-value { margin: 2px;}
811.session-inspector-var { margin: 0px; }
812#session-inspector-table { margin: 0px; width: 600px;}
813#session-inspector-table tr td, th { padding-left: 10px; border: 1px solid #333; vertical-align: middle; }"))))
814               (if headers
815                   (++ (or builtin-css "") headers)
816                   builtin-css))
817    title: title
818    css: css))
819
820) ; end module
Note: See TracBrowser for help on using the repository browser.