stage 1

simple.scm

@@ -6,7 +6,7 @@
      debug-file page-access-control server-start write-chunk)
 
 (import scheme chicken data-structures utils extras ports srfi-69 files srfi-1)
-(use posix srfi-13 tcp)
+(use posix srfi-13 tcp ports)
 (use intarweb spiffy spiffy-request-vars uri-common
      http-session spiffy-cookies sxml-transforms)
 
@@ -211,6 +211,57 @@
   (when (and (enable-session) (session-valid? (sid)))
     (session-refresh! (sid))))
 
+(use z3)
+(define z (z3:encode-init))
+(define b "")
+(z3:encode z (lambda (s) (display s)) (with-input-from-file "news.scm"
+                                   (lambda () (substring (read-string) 640))))
+(z3:encode z (lambda (s) (set! b s)) "hi, how are you?")
+
+(z3:encode-buffer "hi, how are you?")
+(get-output-string dest)
+(z3:decode-buffer "ËÈÔQÈÈ/WH,JU¨Ì/µ\a\x00")
+(z3:decode-buffer (z3:encode-buffer "hi, how are you?"))
+
+(define (make-chunked-port output-port #!key (buffer-size 4094))
+  (let ((buffer (make-string buffer-size))
+        (output (make-string buffer-size))
+        (z3-handle (z3:init buffer: buffer buffer-size: 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))
+    (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)
+                      (let ((len-written (z3:encode z3-handle
+                                                    (lambda (s)
+                                                      (set! output
+                                                        (string-append output s))) s)))
+                        )
+                      (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")
@@ -231,10 +282,15 @@
          (if ((page-access-control) (car args))
              (begin
                (maybe-create/refresh-session! use-session)
-               (with-output-to-port (response-port (current-response))
+               (let ((chunked-port (make-chunked-port (response-port (current-response)))))
-                 (lambda ()
+                 (with-output-to-port chunked-port
-                   (apply contents (cdr args))
+                   (lambda ()
-                   (display "0\r\n\r\n")))
+                     (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)