[Bese-devel] streaming binary data
Lou Vanek
vanek at acd.net
Sat Jun 10 23:29:59 UTC 2006
This one time, at band camp, Rtveliashvili Denys wrote:
> Hi,
>
> I am looking for a possibility to stream a binary data to user instead
> of HTML.
>
> Imagine a situation when a registration form has to be displayed, and
> the form should show an image with a rendered code which has to be
> entered by user manually to prove that the registration is made by a
> human being. Or, for example, imagine a situation when it is necessary
> to display a pie chart which is dynamically generated on the server
> side. In both situations it is necessary so send a binary content to
> client side and specify the content type.
>
> Does anybody know how to do it in UnCommon Web?
>
> Thank you,
> Denys R.
> _______________________________________________
> bese-devel mailing list
> bese-devel at common-lisp.net
> http://common-lisp.net/cgi-bin/mailman/listinfo/bese-devel
>
This patch is NOT ready for prime time. Do not apply.
It was written only for my system (Clisp and Araneida),
but it should give you a good idea of how to change the character stream to binary.
(Just do a search on 'binary' in the patch.)
The reason why I wrote this is because Clisp MUST send a binary data stream when
the data is UTF8. I have no idea whether this works with any other lisp,
but it should give you good a idea or two and perhaps a starting point.
HTH
Lou Vanek
--
Did you hear about the agnostic insomniac dyslexic? He lay awake at night wondering if there's a Dog.
diff -Narbdwt -u4 -x '*.fas' -x '*.lib' -x _darcs -x docs -x bin -x 'READ*' -I '^\s*;' TMP/ucw_dev.clean/src/backend/araneida.lisp ucw_dev/src/backend/araneida.lisp
--- TMP/ucw_dev.clean/src/backend/araneida.lisp 2006-06-02 07:06:58.765625000 -0400
+++ ucw_dev/src/backend/araneida.lisp 2006-06-09 18:30:35.260750000 -0400
@@ -61,9 +87,12 @@
(ucw.backend.info "Starting up ARANEIDA backend ~S on ~A"
backend
(araneida:urlstring (default-url backend)))
(araneida:start-listening (listener backend))
- #+clisp (araneida:host-serve-events))
+ ;; This next line is important (iff running clisp), but it should run a bit later
+ ;; after we start swank. (This line causes the process to block.)
+ #+nil (araneida:host-serve-events)
+ )
(defmethod shutdown-backend ((backend araneida-backend) &rest init-args)
(declare (ignore init-args))
(ucw.backend.info "Stopping ARANEIDA backend ~S on ~A."
@@ -138,11 +167,15 @@
(defmethod shutdown ((r araneida-request))
nil)
+(defmethod close-request ((request araneida-request))
+ (shutdown request))
+
(defclass araneida-response (response)
((request :accessor request :initarg :request)
(headers :accessor headers :initform '())
+ (status :accessor status :initform "200 OK")
(html-stream :accessor html-stream :initform (make-string-output-stream))))
(defmethod clear-response ((response araneida-response))
(setf (headers response) '()
@@ -156,12 +189,31 @@
(defmethod add-header ((response araneida-response) header-name value)
(push (cons header-name value) (headers response)))
-(defmethod shutdown ((r araneida-response))
+(defmethod send-headers ((response araneida-response))
+ (araneida-send-headers response nil))
+
+(defun content-type-and-charset (response)
+ (let (charset/encoding)
+ (dolist* ((name . value) (headers response))
+ (if (starts-with name "Content-Type")
+ (handler-bind ((condition (lambda (condition)
+ (format t "~%!! parse header error.~%~%")
+ (describe condition)
+ (format t "condition type: ~a~%" (type-of condition))
+ (invoke-debugger condition))))
+ (multiple-value-bind (ctype attributes)
+ (rfc2388:parse-header-value value)
+ (when-bind charset/encoding (assoc "charset" attributes :test #'string=)
+ (setq charset/encoding (cdr charset/encoding)))
+ (return-from content-type-and-charset (values ctype charset/encoding))))))))
+
+(defun araneida-send-headers (response body-length)
(let (content-type content-type/charset content-length expires cache-control location refresh
- pragma set-cookie conditional www-authenticate last-modified extra-headers)
- (dolist* ((&whole header-cons name . value) (headers r))
+ pragma set-cookie conditional www-authenticate last-modified extra-headers
+ (status (assoc "Status" (headers response) :test #'string-equal)))
+ (dolist* ((&whole header-cons name . value) (headers response))
(switch (name :test #'string-equal)
("Content-Type"
(multiple-value-bind (type attributes)
(rfc2388:parse-header-value value)
@@ -178,21 +230,23 @@
("Conditional" (setf conditional value))
("WWW-Authenticate" (setf www-authenticate value))
("Last-Modified" (setf last-modified value))
(t (push header-cons extra-headers))))
- (let ((content (if (starts-with content-type "text")
- (string-to-octets (get-output-stream-string (html-stream r))
- (switch (content-type/charset :test #'string=)
- ("UTF-8" :utf-8)
- (("latin-1" "iso-8859-1") :iso-8859-1)
- (t :us-ascii)))
- ;; um, it's not text. this is really wrong
- (string-to-octets (get-output-stream-string (html-stream r))
- :iso-8859-1))))
- (araneida:request-send-headers (request r)
- :response-code (cdr (assoc "Status" (headers r) :test #'string-equal))
+
+ (assert (listp status) (status) "Response header 'status' cannot be empty.")
+ (or content-length
+ body-length
+ (warn "! content length unknown.~%"))
+
+ (handler-bind ((condition (lambda (condition)
+ (format t "~%!! request-send-headers error.~%~%")
+ (describe condition)
+ (format t "condition type: ~a~%" (type-of condition))
+ (invoke-debugger condition))))
+ (araneida:request-send-headers (request response)
+ :response-code (cdr status)
:content-type (or content-type "text/html")
- :content-length (or content-length (length content))
+ :content-length (or content-length body-length 0)
:expires expires
:cache-control cache-control
:location location
:refresh refresh
@@ -200,16 +254,59 @@
:set-cookie set-cookie
:conditional conditional
:www-authenticate www-authenticate
:last-modified last-modified
- :extra-http-headers extra-headers)
- (write-sequence content (araneida:request-stream (request r))))))
+ :extra-http-headers extra-headers))))
+
+
+(defmethod send-response ((response araneida-response))
+ (shutdown response))
+
+(defmethod shutdown ((resp araneida-response))
+ (multiple-value-bind (content-type content-type/charset)
+ (content-type-and-charset resp)
+ (let* ((s (get-output-stream-string (html-stream resp)))
+ (content (if (starts-with content-type "text")
+ (string-to-octets s
+ (switch (content-type/charset :test #'string=)
+ ("UTF-8" :utf-8)
+ (("latin-1" "iso-8859-1") :iso-8859-1)
+ (t :us-ascii)))
+ ;; um, it's not text. this is really wrong
+ (string-to-octets (get-output-stream-string (html-stream resp))
+ :iso-8859-1))))
+ (araneida-send-headers resp (length content))
+ (handler-bind ((condition (lambda (condition)
+ (format t "~%!! write-sequence error.~%~%")
+ (describe condition)
+ (format t "condition type: ~a~%" (type-of condition))
+ (catch 'abort-action
+ (format t "~a~%~%" (collect-backtrace condition)))
+ (invoke-debugger condition))))
+ (let ((stream (araneida:request-stream (request resp))))
+ (write-binary-sequence content stream))))))
(defmethod make-backend ((backend araneida:http-listener) &key host port)
(make-instance 'ucw:araneida-backend
:listener backend
:default-url (araneida:make-url :scheme "http" :host host :port port)))
+(defun make-binary-stream (araneida-request-obj)
+ (let ((stream (araneida:request-stream araneida-request-obj)))
+ #+clisp (unless (equal (stream-element-type stream) '(unsigned-byte 8))
+ (setf (stream-element-type stream) '(unsigned-byte 8)))
+ stream
+ ))
+
+(defmethod network-stream ((response araneida-response))
+ (make-binary-stream (request response)))
+
+(defmethod network-stream ((request araneida-request))
+ (make-binary-stream (request request)))
+
+(defmethod network-stream ((request araneida:request))
+ (make-binary-stream request))
+
;; Copyright (c) 2003-2006 Edward Marco Baringer
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
diff -Narbdwt -u4 -x '*.fas' -x '*.lib' -x _darcs -x docs -x bin -x 'READ*' -I '^\s*;' TMP/ucw_dev.clean/src/backend/common.lisp ucw_dev/src/backend/common.lisp
--- TMP/ucw_dev.clean/src/backend/common.lisp 2006-06-02 07:06:59.390625000 -0400
+++ ucw_dev/src/backend/common.lisp 2006-06-09 17:58:35.823250000 -0400
@@ -147,13 +157,14 @@
("css" "text/css")
(t "text/plain")))
(get-header response "Content-Length") (princ-to-string (file-length file)))
(send-headers response)
+ (ucw.rerl.server.dribble "defserve: serve-file: sent headers.")
(loop
with buffer = (make-array 8192 :element-type 'unsigned-byte)
for end-pos = (read-sequence buffer file)
until (zerop end-pos) do
- (write-sequence buffer (network-stream request) :end end-pos))))
+ (write-binary-sequence buffer (network-stream request) :end end-pos))))
(defserve (serve-sequence (sequence &key
(request (context.request *context*))
(response (context.response *context*))
@@ -169,9 +180,30 @@
sequence)))
(setf (get-header response "Content-Type") content-type
(get-header response "Content-Length") (princ-to-string (length bytes)))
(send-headers response)
- (write-sequence bytes (network-stream request)))))
+ (write-binary-sequence bytes (network-stream request)))))
+
+(defun write-binary-sequence (sequence stream &rest rest &key (start 0) (end nil))
+ (declare (ignore start end))
+ (handler-bind ((condition (lambda (condition)
+ (if nil
+ (progn
+ (format t "~%!!! write-binary-sequence error.~%~%")
+ (describe condition)
+ (format t "condition type: ~a~%" (type-of condition))
+ (catch 'abort-action
+ (format t "~a~%~%" (collect-backtrace condition)))
+ (invoke-debugger condition))
+ (warn "- null sequence sent to output stream.")))))
+ (if (null sequence)
+ (signal 'null-content)
+ (progn
+ ; cannot send binary data to character socket (must be made binary socket)
+ #+clisp (unless (equal (stream-element-type stream) '(unsigned-byte 8))
+ (setf (stream-element-type stream) '(unsigned-byte 8)))
+ (apply #'write-sequence sequence stream rest)))))
+
;;;; Parsing HTTP request bodies.
;;;; The httpd, mod_lisp and araneida backends use this code.
More information about the bese-devel
mailing list