diff --git a/simple.scm b/simple.scm index 04a349c..6f689c2 100644 --- a/simple.scm +++ b/simple.scm @@ -3,7 +3,7 @@ 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 write-chunk $session-destroy!) + debug-file page-access-control server-start $session-destroy!) (import scheme chicken data-structures utils extras ports srfi-69 files srfi-1) (use posix srfi-13 tcp ports) @@ -133,26 +133,7 @@ (reset-per-request-parameters) (let ((handler (lambda (path proc) - (with-headers - (or (server-response-headers) - `((content-type text/html) (transfer-encoding chunked))) - (lambda () - (write-logged-response) - (proc) - (unless (eq? 'HEAD (request-method (current-request))) - (if (%error) - (send-response code: 500 - reason: "Internal server error" - body: ((sxml->html) ((page-exception-message) - (%error))) - headers: '((content-type text/html))) - (if (%redirect) ;; redirection - (let ((new-uri (if (string? (%redirect)) - (uri-reference (%redirect)) - (%redirect)))) - (with-headers `((location ,new-uri)) - (lambda () - (send-status 302 "Found")))))))))))) + (proc)))) (call/cc (lambda (continue) (for-each (lambda (hook) ((cdr hook) path @@ -215,46 +196,6 @@ (when (and (enable-session) (session-valid? (sid))) (session-refresh! (sid)))) -(define (make-chunked-port output-port #!key (buffer-size 4094)) - (let ((buffer (make-string buffer-size)) - (pos 0)) - (define (flush) - (fprintf output-port "~X" pos) - (display "\n" output-port) - (if (fx= pos buffer-size) - (display buffer output-port) - (display (substring buffer 0 pos) output-port)) - (display "\n" output-port) - (flush-output output-port) - (set! pos 0)) - (make-output-port - (lambda (s) - (let ((len (##core#inline "C_block_size" s))) - (let loop ((s-pos 0)) - (if (fx>= (fx+ len pos) buffer-size) - (begin (##core#inline "C_substring_copy" s buffer s-pos - (fx+ (fx- buffer-size pos) s-pos) pos) - (set! len (fx- len (fx- buffer-size pos))) - (set! s-pos (fx+ s-pos (fx- buffer-size pos))) - (set! pos buffer-size) - (flush) - (set! pos 0) - (loop s-pos)) - (begin (##core#inline "C_substring_copy" s buffer s-pos (fx+ len s-pos) pos) - (set! pos (fx+ pos len))))))) - (lambda () - (flush) - (display "0\r\n\r\n" output-port) - (flush-output output-port)) - flush))) - -(define (write-chunk contents) - (printf "~X" (string-length contents)) - (display "\n") - (display contents) - (display "\n") - (flush-output (response-port (current-response)))) - (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) @@ -267,26 +208,14 @@ (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) - (let ((chunked-port (make-chunked-port (response-port (current-response))))) - (with-output-to-port chunked-port - (lambda () - (apply contents (cdr args)))) - (close-output-port chunked-port)) - ;; (with-output-to-port (response-port (current-response)) - ;; (lambda () - ;; (apply contents (cdr args)) - ;; (display "0\r\n\r\n"))) - (finish-response-body (current-response)) - ;; (handle-exceptions exn - ;; (render-exception exn) - ;; ;; TODO render-page - ;; ) - ) - ((page-access-denied-message) path))) - ;; TODO what is this? (redirect-to-login-page - ;; (or given-path path) - ) + (send-response + body: + (with-output-to-string + (lambda () + (apply contents (cdr args)))))) + ((page-access-denied-message) path)))) method)) (define (server-start)