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

Maybe fixing session issues.

Browse Source
master
Thomas Hintz 10 years ago
parent 8051b3bdeb
commit 020d3d3ede
1 changed files with 22 additions and 9 deletions
Show Stats Download Patch File Download Diff File

23
simple.scm
Unescape Escape 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)
(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 (send-response
body: body:
(with-output-to-string (with-output-to-string
(lambda () (lambda ()
(apply contents (cdr args)))))) (apply contents (cdr args)))))))
((page-access-denied-message) path)))) ((page-access-denied-message) path))))
method)) method))

Write Preview
Loading…
Cancel
Save