tjhintz/simple
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Maybe fixing session issues.

Browse Source
This commit is contained in:
Thomas Hintz
2015-08-01 11:11:16 -07:00
parent 8051b3bdeb
commit 020d3d3ede
1 changed files with 22 additions and 9 deletions
Download Patch File Download Diff File Expand all files Collapse all files

31
simple.scm
View File

@@ -187,23 +187,36 @@
(define (define-page path contents #!key css title doctype headers charset (define (define-page path contents #!key css title doctype headers charset
(method 'GET) use-session) ;; for define-session-page (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! (add-resource!
path path
;; args is path + any procedure match args ;; args is path + any procedure match args
(lambda args (lambda args
(sid (get-sid use-session)) ;; (sid (get-sid use-session))
(server-refresh-session!) ;; (server-refresh-session!)
(if (use-session? use-session) (if (use-session? use-session)
(if ((page-access-control) (car args)) (if ((page-access-control) (car args))
(begin (begin
;; TODO is this a duplicate of the above? ;; TODO is this a duplicate of the above?
(maybe-create/refresh-session! use-session) ;; (maybe-create/refresh-session! use-session)
(send-response (handle-exceptions
body: exn
(with-output-to-string (if ((condition-predicate 'redirect) exn)
(lambda () (let ((new-uri ((condition-property-accessor 'redirect 'uri) exn)))
(apply contents (cdr args)))))) (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)))) ((page-access-denied-message) path))))
method)) method))