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

Removing chunked encoding and switching to content-length.

Browse Source
This commit is contained in:
Thomas Hintz
2015-04-30 13:26:28 -07:00
parent b1b77db5f3
commit 935d7a0b8d
1 changed files with 9 additions and 80 deletions
Download Patch File Download Diff File Expand all files Collapse all files

89
simple.scm
View File

@@ -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)