summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorThomas Hintz <t@thintz.com>2015-08-01 11:11:16 -0700
committerThomas Hintz <t@thintz.com>2015-08-01 11:11:16 -0700
commit020d3d3ede6f62a699892989a869832864f1e8a6 (patch)
treef52067ccfdd8481b1983abb17af6c7cffde855b4
parent8051b3bdeb5beefede199e8c0568b410fb40c9b2 (diff)
downloadsimple-020d3d3ede6f62a699892989a869832864f1e8a6.tar.gz
Maybe fixing session issues.HEADmaster
-rw-r--r--simple.scm31
1 files changed, 22 insertions, 9 deletions
diff --git a/simple.scm b/simple.scm
index 8a48377..17ff6e5 100644
--- a/simple.scm
+++ b/simple.scm
@@ -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))