|
|
|
|
@ -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)
|
|
|
|
|
;; (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))))))
|
|
|
|
|
(apply contents (cdr args)))))))
|
|
|
|
|
((page-access-denied-message) path))))
|
|
|
|
|
method))
|
|
|
|
|
|
|
|
|
|
|
