| 1 |
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CHUNGA; Base: 10 -*- |
|---|
| 2 |
;;; $Header: /usr/local/cvsrep/chunga/input.lisp,v 1.18 2008/05/24 03:06:22 edi Exp $ |
|---|
| 3 |
|
|---|
| 4 |
;;; Copyright (c) 2006-2008, Dr. Edmund Weitz. All rights reserved. |
|---|
| 5 |
|
|---|
| 6 |
;;; Redistribution and use in source and binary forms, with or without |
|---|
| 7 |
;;; modification, are permitted provided that the following conditions |
|---|
| 8 |
;;; are met: |
|---|
| 9 |
|
|---|
| 10 |
;;; * Redistributions of source code must retain the above copyright |
|---|
| 11 |
;;; notice, this list of conditions and the following disclaimer. |
|---|
| 12 |
|
|---|
| 13 |
;;; * Redistributions in binary form must reproduce the above |
|---|
| 14 |
;;; copyright notice, this list of conditions and the following |
|---|
| 15 |
;;; disclaimer in the documentation and/or other materials |
|---|
| 16 |
;;; provided with the distribution. |
|---|
| 17 |
|
|---|
| 18 |
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED |
|---|
| 19 |
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED |
|---|
| 20 |
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
|---|
| 21 |
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY |
|---|
| 22 |
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
|---|
| 23 |
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE |
|---|
| 24 |
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS |
|---|
| 25 |
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, |
|---|
| 26 |
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING |
|---|
| 27 |
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS |
|---|
| 28 |
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
|---|
| 29 |
|
|---|
| 30 |
(in-package :chunga) |
|---|
| 31 |
|
|---|
| 32 |
(defmethod chunked-input-stream-extensions (object) |
|---|
| 33 |
"The default method which always returns the empty list." |
|---|
| 34 |
nil) |
|---|
| 35 |
|
|---|
| 36 |
(defmethod chunked-input-stream-trailers (object) |
|---|
| 37 |
"The default method which always returns the empty list." |
|---|
| 38 |
nil) |
|---|
| 39 |
|
|---|
| 40 |
(defmethod chunked-stream-input-chunking-p (object) |
|---|
| 41 |
"The default method for all objects which are not of type |
|---|
| 42 |
CHUNKED-INPUT-STREAM." |
|---|
| 43 |
nil) |
|---|
| 44 |
|
|---|
| 45 |
(defmethod (setf chunked-stream-input-chunking-p) (new-value (stream chunked-input-stream)) |
|---|
| 46 |
"Switches input chunking for STREAM on or off." |
|---|
| 47 |
(unless (eq (not new-value) (not (chunked-stream-input-chunking-p stream))) |
|---|
| 48 |
(with-slots (input-limit input-index expecting-crlf-p chunk-extensions chunk-trailers) |
|---|
| 49 |
stream |
|---|
| 50 |
(cond (new-value |
|---|
| 51 |
(setq expecting-crlf-p nil |
|---|
| 52 |
input-limit 0 |
|---|
| 53 |
input-index 0 |
|---|
| 54 |
chunk-extensions nil |
|---|
| 55 |
chunk-trailers nil)) |
|---|
| 56 |
(t (when (< input-index input-limit) |
|---|
| 57 |
(error "Not all chunks from ~S have been read completely." |
|---|
| 58 |
stream)))))) |
|---|
| 59 |
(setf (slot-value stream 'input-chunking-p) new-value)) |
|---|
| 60 |
|
|---|
| 61 |
(defmethod stream-clear-input ((stream chunked-input-stream)) |
|---|
| 62 |
"Implements CLEAR-INPUT by resetting the internal chunk buffer." |
|---|
| 63 |
(when (chunked-stream-input-chunking-p stream) |
|---|
| 64 |
(setf (chunked-stream-input-index stream) 0 |
|---|
| 65 |
(chunked-stream-input-limit stream) 0)) |
|---|
| 66 |
;; clear input on inner stream |
|---|
| 67 |
(clear-input (chunked-stream-stream stream)) |
|---|
| 68 |
nil) |
|---|
| 69 |
|
|---|
| 70 |
(defmethod chunked-input-available-p ((stream chunked-input-stream)) |
|---|
| 71 |
"Whether there's unread input waiting in the chunk buffer." |
|---|
| 72 |
(< (chunked-stream-input-index stream) |
|---|
| 73 |
(chunked-stream-input-limit stream))) |
|---|
| 74 |
|
|---|
| 75 |
(defmethod stream-listen ((stream chunked-input-stream)) |
|---|
| 76 |
"We first check if input chunking is enabled and if there's |
|---|
| 77 |
something in the buffer. Otherwise we poll the underlying stream." |
|---|
| 78 |
(cond ((chunked-stream-input-chunking-p stream) |
|---|
| 79 |
(or (chunked-input-available-p stream) |
|---|
| 80 |
(fill-buffer stream))) |
|---|
| 81 |
(t (listen (chunked-stream-stream stream))))) |
|---|
| 82 |
|
|---|
| 83 |
(defmethod fill-buffer ((stream chunked-input-stream)) |
|---|
| 84 |
"Re-fills the chunk buffer. Returns NIL if chunking has ended." |
|---|
| 85 |
(let ((inner-stream (chunked-stream-stream stream)) |
|---|
| 86 |
;; set up error function for the functions in `read.lisp' |
|---|
| 87 |
(*current-error-function* |
|---|
| 88 |
(lambda (last-char expected-chars) |
|---|
| 89 |
"The function which is called when an unexpected |
|---|
| 90 |
character is seen. Signals INPUT-CHUNKING-BODY-CORRUPTED." |
|---|
| 91 |
(error 'input-chunking-body-corrupted |
|---|
| 92 |
:stream stream |
|---|
| 93 |
:last-char last-char |
|---|
| 94 |
:expected-chars expected-chars)))) |
|---|
| 95 |
(labels ((add-extensions () |
|---|
| 96 |
"Reads chunk extensions \(if there are any) and stores |
|---|
| 97 |
them into the corresponding slot of the stream." |
|---|
| 98 |
(when-let (extensions (read-name-value-pairs inner-stream)) |
|---|
| 99 |
(warn "Adding uninterpreted extensions to stream ~S." stream) |
|---|
| 100 |
(setf (slot-value stream 'chunk-extensions) |
|---|
| 101 |
(append (chunked-input-stream-extensions stream) extensions))) |
|---|
| 102 |
(assert-crlf inner-stream)) |
|---|
| 103 |
(get-chunk-size () |
|---|
| 104 |
"Reads chunk size header \(including optional |
|---|
| 105 |
extensions) and returns the size." |
|---|
| 106 |
(with-character-stream-semantics |
|---|
| 107 |
(when (expecting-crlf-p stream) |
|---|
| 108 |
(assert-crlf inner-stream)) |
|---|
| 109 |
(setf (expecting-crlf-p stream) t) |
|---|
| 110 |
;; read hexadecimal number |
|---|
| 111 |
(let (last-char) |
|---|
| 112 |
(prog1 (loop for weight = (digit-char-p (setq last-char (read-char* inner-stream)) |
|---|
| 113 |
16) |
|---|
| 114 |
for result = (if weight |
|---|
| 115 |
(+ weight (* 16 (or result 0))) |
|---|
| 116 |
(return (or result |
|---|
| 117 |
(error 'input-chunking-body-corrupted |
|---|
| 118 |
:stream stream |
|---|
| 119 |
:last-char last-char |
|---|
| 120 |
:expected-chars +hex-digits+))))) |
|---|
| 121 |
;; unread first octet which wasn't a digit |
|---|
| 122 |
(unread-char* last-char) |
|---|
| 123 |
(add-extensions)))))) |
|---|
| 124 |
(let ((chunk-size (get-chunk-size))) |
|---|
| 125 |
(with-slots (input-buffer input-limit input-index) |
|---|
| 126 |
stream |
|---|
| 127 |
(setq input-index 0 |
|---|
| 128 |
input-limit chunk-size) |
|---|
| 129 |
(cond ((zerop chunk-size) |
|---|
| 130 |
;; turn chunking off |
|---|
| 131 |
(setf (chunked-stream-input-chunking-p stream) nil |
|---|
| 132 |
(slot-value stream 'chunk-trailers) (with-character-stream-semantics |
|---|
| 133 |
(read-http-headers inner-stream)) |
|---|
| 134 |
input-limit 0) |
|---|
| 135 |
;; return NIL |
|---|
| 136 |
(return-from fill-buffer)) |
|---|
| 137 |
((> chunk-size (length input-buffer)) |
|---|
| 138 |
;; replace buffer if it isn't big enough for the next chunk |
|---|
| 139 |
(setq input-buffer (make-array chunk-size :element-type '(unsigned-byte 8))))) |
|---|
| 140 |
(unless (= (read-sequence input-buffer inner-stream :start 0 :end chunk-size) |
|---|
| 141 |
chunk-size) |
|---|
| 142 |
(error 'input-chunking-unexpected-end-of-file |
|---|
| 143 |
:stream stream)) |
|---|
| 144 |
chunk-size))))) |
|---|
| 145 |
|
|---|
| 146 |
(defmethod stream-read-byte ((stream chunked-input-stream)) |
|---|
| 147 |
"Reads one byte from STREAM. Checks the chunk buffer first, if |
|---|
| 148 |
input chunking is enabled. Re-fills buffer is necessary." |
|---|
| 149 |
(unless (chunked-stream-input-chunking-p stream) |
|---|
| 150 |
(return-from stream-read-byte (read-byte (chunked-stream-stream stream) nil :eof))) |
|---|
| 151 |
(unless (chunked-input-available-p stream) |
|---|
| 152 |
(unless (fill-buffer stream) |
|---|
| 153 |
(return-from stream-read-byte :eof))) |
|---|
| 154 |
(with-slots (input-buffer input-index) |
|---|
| 155 |
stream |
|---|
| 156 |
(prog1 (aref input-buffer input-index) |
|---|
| 157 |
(incf input-index)))) |
|---|
| 158 |
|
|---|
| 159 |
(defmethod stream-read-sequence ((stream chunked-input-stream) sequence start end &key) |
|---|
| 160 |
"Fills SEQUENCE by adding data from the chunk buffer and re-filling |
|---|
| 161 |
it until enough data was read. Works directly on the underlying |
|---|
| 162 |
stream if input chunking is off." |
|---|
| 163 |
(unless (chunked-stream-input-chunking-p stream) |
|---|
| 164 |
(return-from stream-read-sequence |
|---|
| 165 |
(read-sequence sequence (chunked-stream-stream stream) :start start :end end))) |
|---|
| 166 |
(loop |
|---|
| 167 |
(when (>= start end) |
|---|
| 168 |
(return-from stream-read-sequence start)) |
|---|
| 169 |
(unless (chunked-input-available-p stream) |
|---|
| 170 |
(unless (fill-buffer stream) |
|---|
| 171 |
(return-from stream-read-sequence start))) |
|---|
| 172 |
(with-slots (input-buffer input-limit input-index) |
|---|
| 173 |
stream |
|---|
| 174 |
(replace sequence input-buffer |
|---|
| 175 |
:start1 start :end1 end |
|---|
| 176 |
:start2 input-index :end2 input-limit) |
|---|
| 177 |
(let ((length (min (- input-limit input-index) |
|---|
| 178 |
(- end start)))) |
|---|
| 179 |
(incf start length) |
|---|
| 180 |
(incf input-index length))))) |
|---|