diff options
| author | Thomas Hintz <t@thintz.com> | 2015-08-01 11:11:16 -0700 |
|---|---|---|
| committer | Thomas Hintz <t@thintz.com> | 2015-08-01 11:11:16 -0700 |
| commit | 020d3d3ede6f62a699892989a869832864f1e8a6 (patch) | |
| tree | f52067ccfdd8481b1983abb17af6c7cffde855b4 | |
| parent | 8051b3bdeb5beefede199e8c0568b410fb40c9b2 (diff) | |
| download | simple-020d3d3ede6f62a699892989a869832864f1e8a6.tar.gz | |
| -rw-r--r-- | simple.scm | 31 |
1 files changed, 22 insertions, 9 deletions
@@ -187,23 +187,36 @@ (define (define-page path contents #!key css title doctype headers charset (method 'GET) use-session) ;; for define-session-page - (##sys#check-closure contents 'define-page) + (unless (procedure? contents) (error "contents must be a procedure")) (add-resource! path ;; args is path + any procedure match args (lambda args - (sid (get-sid use-session)) - (server-refresh-session!) + ;; (sid (get-sid use-session)) + ;; (server-refresh-session!) (if (use-session? use-session) (if ((page-access-control) (car args)) (begin ;; TODO is this a duplicate of the above? - (maybe-create/refresh-session! use-session) - (send-response - body: - (with-output-to-string - (lambda () - (apply contents (cdr args)))))) + ;; (maybe-create/refresh-session! use-session) + (handle-exceptions + exn + (if ((condition-predicate 'redirect) exn) + (let ((new-uri ((condition-property-accessor 'redirect 'uri) exn))) + (send-response + body: + (string-append + "<html><head><meta http-equiv=\"refresh\" content=\"0; URL=" + (cond ((string? new-uri) new-uri) + ((uri-reference? new-uri) (uri->string new-uri)) + (else (abort "invalid URI construct"))) + "\"></head></html"))) + (abort exn)) + (send-response + body: + (with-output-to-string + (lambda () + (apply contents (cdr args))))))) ((page-access-denied-message) path)))) method)) |