;;;; ; ;;;; (c) 2002 by Jochen Schmidt. ;;;; ;;;; File: chunked-stream-mixin.lisp ;;;; Revision: 0.1 ;;;; Description: ACL style HTTP1.1 I/O chunking ;;;; Date: 08.04.2002 ;;;; Authors: Jochen Schmidt ;;;; Tel: (+49 9 11) 47 20 603 ;;;; Email: jsc@dataheaven.de ;;;; ;;;; Redistribution and use in source and binary forms, with or without ;;;; modification, are permitted provided that the following conditions ;;;; are met: ;;;; 1. Redistributions of source code must retain the above copyright ;;;; notice, this list of conditions and the following disclaimer. ;;;; 2. Redistributions in binary form must reproduce the above copyright ;;;; notice, this list of conditions and the following disclaimer in the ;;;; documentation and/or other materials provided with the distribution. ;;;; ;;;; THIS SOFTWARE IS PROVIDED "AS IS" AND THERE ARE NEITHER ;;;; EXPRESSED NOR IMPLIED WARRANTIES - THIS INCLUDES, BUT ;;;; IS NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY ;;;; AND FITNESS FOR A PARTICULAR PURPOSE.IN NO WAY ARE THE ;;;; AUTHORS LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;;;; SPECIAL, EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT ;;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES ; ;;;; LOSS OF USE, DATA, OR PROFITS ; OR BUSINESS INTERRUPTION) ;;;; ;;;; For further details contact the authors of this software. ;;;; ;;;; Jochen Schmidt ;;;; Zuckmantelstr. 11 ;;;; 91616 Neusitz ;;;; GERMANY ;;;; ;;;; Nuernberg, 08.Apr.2002 Jochen Schmidt ;;;; (in-package :de.dataheaven.chunked-stream-mixin) (defun buffer-ref (buffer index) #+lispworks (schar buffer index) #-lispworks (aref buffer index)) (defun (setf buffer-ref) (new-value buffer index) #-lispworks (setf (aref buffer index) (char-code new-value)) #+lispworks (setf (schar buffer index) new-value)) (defclass chunked-stream-mixin () ((output-chunking-p :initform nil :accessor output-chunking-p) (chunk-input-avail :initform nil :documentation "Number of octets of the current chunk that are not yet read into the buffer, or nil if input chunking is disabled") (real-input-limit :initform 0 :documentation "Index of last octet read into buffer (input-limit points to index of last octet in the current chunk)"))) (defgeneric input-chunking-p (stream)) (defmethod input-chunking-p ((stream chunked-stream-mixin)) (not (null (slot-value stream 'chunk-input-avail)))) (defgeneric (setf input-chunking-p) (new-value stream)) (defmethod (setf input-chunking-p) (new-value (stream chunked-stream-mixin)) (setf (slot-value stream 'chunk-input-avail) (and new-value 0))) (define-condition acl-compat.excl::socket-chunking-end-of-file (condition) ((acl-compat.excl::format-arguments :initform nil :initarg :format-arguments) (acl-compat.excl::format-control :initform "A chunking end of file occured" :initarg :format-control))) ;;;;;;;;;;;;;;;;;;;;;; ;;; Input chunking ;;; ;;;;;;;;;;;;;;;;;;;;;; ;; Input chunking is not tested so far! (defgeneric initialize-input-chunking (stream)) (defmethod initialize-input-chunking ((stream chunked-stream-mixin)) "This method initializes input chunking. The real-input-limit is nil in the beginnings because it got not saved yet. Chunk-input-avail is obviously 0 because no chunk-data got read so far." (gray-stream:with-stream-input-buffer (input-buffer input-index input-limit) stream (with-slots (real-input-limit chunk-input-avail) stream (setf ;; Bytes read from stream (valid data in buffer up to here) real-input-limit input-limit ;; Bytes available in current chunk block after buffer contents ;; runs out (trivially zero before first chunk block read) chunk-input-avail 0 ;; Last buffer position that can be read before new data has to ;; be fetched from stream (we must begin with parsing a chunk ;; immediately; hence set to a value that guarantees this) input-limit 0 ; or input-index? )))) ;; Lispworks fix by Edi Weitz (paserve-help 2003-11-28) #+lispworks (defmacro %with-stream-input-buffer ((input-buffer input-index input-limit) stream &body body) `(with-slots ((,input-buffer stream::input-buffer) (,input-index stream::input-index) (,input-limit stream::input-limit)) (slot-value ,stream 'stream::buffer-state) ,@body)) (defmethod gray-stream:stream-fill-buffer ((stream chunked-stream-mixin)) "Refill buffer from stream." ;; STREAM-FILL-BUFFER gets called when the input-buffer contains no ;; more data (the index is bigger than the limit). We call out to ;; the real buffer filling mechanism by calling the next specialized ;; method. This method is responsible to update the buffer state in ;; coordination with the chunk-header. (with-slots (chunk-input-avail real-input-limit) stream (#-lispworks gray-stream:with-stream-input-buffer #+lispworks %with-stream-input-buffer (input-buffer input-index input-limit) stream (labels ((pop-char () (when (and (>= input-index input-limit) ; need new data (not (call-next-method))) ; couldn't get it (error "Unexpected end-of-file while reading chunk block")) (prog1 #-lispworks (code-char (buffer-ref input-buffer input-index)) #+lispworks (buffer-ref input-buffer input-index) (incf input-index))) (read-chunk-header () (let ((chunk-length 0)) (tagbody initial-crlf (let ((char (pop-char))) (cond ((digit-char-p char 16) (decf input-index) ; unread char (go chunk-size)) ((eq #\Return char) (if (eq (pop-char) #\Linefeed) (go chunk-size) (error "End of chunk-header corrupted: Expected Linefeed"))) (t (error "End of chunk-header corrupted: Expected Carriage Return or a digit")))) chunk-size (let ((char (pop-char))) (cond ((digit-char-p char 16) (setf chunk-length (+ (* 16 chunk-length) (digit-char-p char 16))) (go chunk-size)) (t (decf input-index) ; unread char (go skip-rest)))) skip-rest (if (eq #\Return (pop-char)) (go check-linefeed) (go skip-rest)) check-linefeed (let ((char (pop-char))) (case char (#\Linefeed (go accept)) (t (error "End of chunk-header corrupted: LF expected, ~A read." char)))) accept) chunk-length))) (cond ((not (input-chunking-p stream)) ;; Chunking not active; just fill buffer normally (call-next-method)) ((zerop chunk-input-avail) ;; We are at the beginning of a new chunk. (when real-input-limit (setf input-limit real-input-limit)) (let* ((chunk-length (read-chunk-header)) (end-of-chunk (+ input-index chunk-length))) (if (zerop chunk-length) ;; rfc2616 indicates that input chunking is ;; turned off after zero-length chunk is read ;; (see section 19.4.6) -- turn off chunking (progn (signal 'acl-compat.excl::socket-chunking-end-of-file :format-arguments stream) (setf (input-chunking-p stream) nil) ;; TODO: whoever handles ;; socket-chunking-end-of-file (client.cl ;; in AllegroServe's case) should read the ;; trailer (see section 3.6). All we can ;; reasonably do here is turn off ;; chunking, or throw information away. ) ;; Now set up stream attributes so that read methods ;; call refill-buffer both at end of chunk and end of ;; buffer (progn (setf real-input-limit input-limit input-limit (min real-input-limit end-of-chunk) chunk-input-avail (max 0 (- end-of-chunk real-input-limit))) input-limit)))) (t ;; We are in the middle of a chunk; re-fill buffer (if (call-next-method) (progn (setf real-input-limit input-limit) (setf input-limit (min real-input-limit chunk-input-avail)) (setf chunk-input-avail (max 0 (- chunk-input-avail real-input-limit))) input-limit) (error "Unexpected end-of-file in the middle of a chunk")))))))) ;;;;;;;;;;;;;;;;;;;;;;; ;;; Output chunking ;;; ;;;;;;;;;;;;;;;;;;;;;;; ;; This constant is the amount of bytes the system reserves for the chunk-header ;; It is calculated as 4 bytes for the chunk-size in hexadecimal digits and a CR followed ;; by a LF (defconstant +chunk-header-buffer-offset+ 6) (defgeneric initialize-output-chunking (stream)) (defmethod initialize-output-chunking ((stream chunked-stream-mixin)) "This method initializes output chunking. Actual contents in the output-buffer get flushed first. A chunk has a header at the start and a CRLF at the end. The header is the length of the (data) content in the chunk as a string in hexadecimal digits and a trailing CRLF before the real content begins. We assume that the content of a chunk is never bigger than #xFFFF and therefore reserve 6 bytes at the beginning of the buffer for the header. We reduce the buffer limit by 2 so that we have always room left in the buffer to attach a CRLF." (unless (output-chunking-p stream) (force-output stream) (gray-stream:with-stream-output-buffer (buffer index limit) stream (setf index +chunk-header-buffer-offset+) (setf (buffer-ref buffer (- +chunk-header-buffer-offset+ 2)) #\Return (buffer-ref buffer (1- +chunk-header-buffer-offset+)) #\Linefeed) (decf limit 2) (setf (output-chunking-p stream) t)))) (defmethod gray-stream:stream-flush-buffer ((stream chunked-stream-mixin)) "When there is pending content in the output-buffer then compute the chunk-header and flush the buffer" (if (output-chunking-p stream) (gray-stream:with-stream-output-buffer (output-buffer output-index output-limit) stream (when (> output-index +chunk-header-buffer-offset+) (let* ((chunk-header (format nil "~X" (- output-index +chunk-header-buffer-offset+))) (start (- +chunk-header-buffer-offset+ 2 (length chunk-header)))) (loop for c across chunk-header for i upfrom start do (setf (buffer-ref output-buffer i) c)) (setf (buffer-ref output-buffer output-index) #\Return (buffer-ref output-buffer (1+ output-index)) #\Linefeed) (gray-stream:stream-write-buffer stream output-buffer start (+ output-index 2)) (setf output-index +chunk-header-buffer-offset+)))) (call-next-method))) (defmethod close ((stream chunked-stream-mixin) &key abort) (unless abort (disable-output-chunking stream)) (call-next-method)) (defgeneric disable-output-chunking (stream)) (defmethod disable-output-chunking ((stream chunked-stream-mixin)) "When we disable chunking we first try to write out a last pending chunk and after that reset the buffer-state to normal mode. To end the game we write out a chunk-header with a chunk-size of zero to notify the peer that chunking ends." (when (output-chunking-p stream) (force-output stream) (gray-stream:with-stream-output-buffer (buffer index limit) stream (setf index 0) (incf limit 2)) (setf (output-chunking-p stream) nil (input-chunking-p stream) nil) (format stream "0~A~A~A~A" #\Return #\Linefeed #\Return #\Linefeed) (force-output stream)))