summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorThomas Hintz <t@thintz.com>2015-04-30 13:26:28 -0700
committerThomas Hintz <t@thintz.com>2015-04-30 13:26:28 -0700
commit935d7a0b8d04447626ff7741f0b0005d819adad5 (patch)
treef1bfdf0ba7abceea974171efbbff1842b4532949
parentb1b77db5f30684cda1ba7e1cd572e8da38677cde (diff)
downloadsimple-935d7a0b8d04447626ff7741f0b0005d819adad5.tar.gz
Removing chunked encoding and switching to content-length.
-rw-r--r--simple.scm89
1 files changed, 9 insertions, 80 deletions
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)