|
|
|
@ -1,9 +1,9 @@
|
|
|
|
|
(module simple
|
|
|
|
|
(server-response-headers sid page-exception-message enable-session
|
|
|
|
|
(server-response-headers sid enable-session
|
|
|
|
|
add-request-handler-hook! remove-request-handler-hook!
|
|
|
|
|
define-page redirect-to enable-session-cookie session-cookie-setter
|
|
|
|
|
session-cookie-name $session $session-set! $ page-access-denied-message
|
|
|
|
|
debug-file page-access-control server-start $session-destroy!
|
|
|
|
|
page-access-control server-start $session-destroy!
|
|
|
|
|
add-post-request-handler-hook!)
|
|
|
|
|
|
|
|
|
|
(import scheme chicken data-structures utils extras ports srfi-69 files srfi-1)
|
|
|
|
@ -11,13 +11,9 @@
|
|
|
|
|
(use intarweb spiffy spiffy-request-vars uri-common
|
|
|
|
|
http-session spiffy-cookies sxml-transforms)
|
|
|
|
|
|
|
|
|
|
(define debug-file (make-parameter #f))
|
|
|
|
|
(define server-response-headers (make-parameter #f))
|
|
|
|
|
(define sid (make-parameter #f))
|
|
|
|
|
(define page-exception-message
|
|
|
|
|
(make-parameter
|
|
|
|
|
(lambda (exn)
|
|
|
|
|
'(<h3> "An error has occurred while processing your request."))))
|
|
|
|
|
|
|
|
|
|
(define enable-session (make-parameter #f))
|
|
|
|
|
(define enable-session-cookie (make-parameter #t))
|
|
|
|
|
(define session-cookie-name (make-parameter "awful-cookie"))
|
|
|
|
@ -87,26 +83,11 @@
|
|
|
|
|
(%error #f)
|
|
|
|
|
(%page-title #f))
|
|
|
|
|
|
|
|
|
|
(define (debug . args)
|
|
|
|
|
(when (debug-file)
|
|
|
|
|
(with-output-to-file (debug-file)
|
|
|
|
|
(lambda ()
|
|
|
|
|
(print (concat args)))
|
|
|
|
|
append:)))
|
|
|
|
|
|
|
|
|
|
(define-inline (use-session? use-session)
|
|
|
|
|
(or (not (enable-session))
|
|
|
|
|
use-session
|
|
|
|
|
(and (enable-session) (session-valid? (sid)))))
|
|
|
|
|
|
|
|
|
|
(define-inline (render-exception exn)
|
|
|
|
|
(%error exn)
|
|
|
|
|
(debug (with-output-to-string
|
|
|
|
|
(lambda ()
|
|
|
|
|
(print-call-chain)
|
|
|
|
|
(print-error-message exn))))
|
|
|
|
|
((page-exception-message) exn))
|
|
|
|
|
|
|
|
|
|
(define-inline (maybe-create/refresh-session! use-session)
|
|
|
|
|
(when use-session
|
|
|
|
|
(if (session-valid? (sid))
|
|
|
|
|