| 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-2010, 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 t)) |
|---|
| 33 | "The default method which always returns the empty list." |
|---|
| 34 | nil) |
|---|
| 35 | |
|---|
| 36 | (defmethod chunked-input-stream-trailers ((object t)) |
|---|
| 37 | "The default method which always returns the empty list." |
|---|
| 38 | nil) |
|---|
| 39 | |
|---|
| 40 | (defmethod chunked-stream-input-chunking-p ((object t)) |
|---|
| 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 'parameter-error |
|---|
| 58 | :stream stream |
|---|
| 59 | :format-control "Not all chunks from ~S have been read completely." |
|---|
| 60 | :format-arguments (list stream))))))) |
|---|
| 61 | (setf (slot-value stream 'input-chunking-p) new-value)) |
|---|
| 62 | |
|---|
| 63 | (defmethod stream-clear-input ((stream chunked-input-stream)) |
|---|
| 64 | "Implements CLEAR-INPUT by resetting the internal chunk buffer." |
|---|
| 65 | (when (chunked-stream-input-chunking-p stream) |
|---|
| 66 | (setf (chunked-stream-input-index stream) 0 |
|---|
| 67 | (chunked-stream-input-limit stream) 0)) |
|---|
| 68 | ;; clear input on inner stream |
|---|
| 69 | (clear-input (chunked-stream-stream stream)) |
|---|
| 70 | nil) |
|---|
| 71 | |
|---|
| 72 | (defmethod chunked-input-available-p ((stream chunked-input-stream)) |
|---|
| 73 | "Whether there's unread input waiting in the chunk buffer." |
|---|
| 74 | (< (chunked-stream-input-index stream) |
|---|
| 75 | (chunked-stream-input-limit stream))) |
|---|
| 76 | |
|---|
| 77 | (defmethod stream-listen ((stream chunked-input-stream)) |
|---|
| 78 | "We first check if input chunking is enabled and if there's |
|---|
| 79 | something in the buffer. Otherwise we poll the underlying stream." |
|---|
| 80 | (cond ((chunked-stream-input-chunking-p stream) |
|---|
| 81 | (or (chunked-input-available-p stream) |
|---|
| 82 | (fill-buffer stream))) |
|---|
| 83 | (t (listen (chunked-stream-stream stream))))) |
|---|
| 84 | |
|---|
| 85 | (defmethod fill-buffer ((stream chunked-input-stream)) |
|---|
| 86 | "Re-fills the chunk buffer. Returns NIL if chunking has ended." |
|---|
| 87 | (let ((inner-stream (chunked-stream-stream stream)) |
|---|
| 88 | ;; set up error function for the functions in `read.lisp' |
|---|
| 89 | (*current-error-function* |
|---|
| 90 | (lambda (last-char expected-chars) |
|---|
| 91 | "The function which is called when an unexpected |
|---|
| 92 | character is seen. Signals INPUT-CHUNKING-BODY-CORRUPTED." |
|---|
| 93 | (error 'input-chunking-body-corrupted |
|---|
| 94 | :stream stream |
|---|
| 95 | :last-char last-char |
|---|
| 96 | :expected-chars expected-chars)))) |
|---|
| 97 | (labels ((add-extensions () |
|---|
| 98 | "Reads chunk extensions \(if there are any) and stores |
|---|
| 99 | them into the corresponding slot of the stream." |
|---|
| 100 | (when-let (extensions (read-name-value-pairs inner-stream)) |
|---|
| 101 | (warn 'chunga-warning |
|---|
| 102 | :stream stream |
|---|
| 103 | :format-control "Adding uninterpreted extensions to stream ~S." |
|---|
| 104 | :format-arguments (list stream)) |
|---|
| 105 | (setf (slot-value stream 'chunk-extensions) |
|---|
| 106 | (append (chunked-input-stream-extensions stream) extensions))) |
|---|
| 107 | (assert-crlf inner-stream)) |
|---|
| 108 | (get-chunk-size () |
|---|
| 109 | "Reads chunk size header \(including optional |
|---|
| 110 | extensions) and returns the size." |
|---|
| 111 | (with-character-stream-semantics |
|---|
| 112 | (when (expecting-crlf-p stream) |
|---|
| 113 | (assert-crlf inner-stream)) |
|---|
| 114 | (setf (expecting-crlf-p stream) t) |
|---|
| 115 | ;; read hexadecimal number |
|---|
| 116 | (let (last-char) |
|---|
| 117 | (prog1 (loop for weight = (digit-char-p (setq last-char (read-char* inner-stream)) |
|---|
| 118 | 16) |
|---|
| 119 | for result = (if weight |
|---|
| 120 | (+ weight (* 16 (or result 0))) |
|---|
| 121 | (return (or result |
|---|
| 122 | (error 'input-chunking-body-corrupted |
|---|
| 123 | :stream stream |
|---|
| 124 | :last-char last-char |
|---|
| 125 | :expected-chars +hex-digits+))))) |
|---|
| 126 | ;; unread first octet which wasn't a digit |
|---|
| 127 | (unread-char* last-char) |
|---|
| 128 | (add-extensions)))))) |
|---|
| 129 | (let ((chunk-size (get-chunk-size))) |
|---|
| 130 | (with-slots (input-buffer input-limit input-index) |
|---|
| 131 | stream |
|---|
| 132 | (setq input-index 0 |
|---|
| 133 | input-limit chunk-size) |
|---|
| 134 | (cond ((zerop chunk-size) |
|---|
| 135 | ;; turn chunking off |
|---|
| 136 | (setf (chunked-stream-input-chunking-p stream) nil |
|---|
| 137 | (slot-value stream 'chunk-trailers) (with-character-stream-semantics |
|---|
| 138 | (read-http-headers inner-stream)) |
|---|
| 139 | input-limit 0) |
|---|
| 140 | ;; return NIL |
|---|
| 141 | (return-from fill-buffer)) |
|---|
| 142 | ((> chunk-size (length input-buffer)) |
|---|
| 143 | ;; replace buffer if it isn't big enough for the next chunk |
|---|
| 144 | (setq input-buffer (make-array chunk-size :element-type '(unsigned-byte 8))))) |
|---|
| 145 | (unless (= (read-sequence input-buffer inner-stream :start 0 :end chunk-size) |
|---|
| 146 | chunk-size) |
|---|
| 147 | (error 'input-chunking-unexpected-end-of-file |
|---|
| 148 | :stream stream)) |
|---|
| 149 | chunk-size))))) |
|---|
| 150 | |
|---|
| 151 | (defmethod stream-read-byte ((stream chunked-input-stream)) |
|---|
| 152 | "Reads one byte from STREAM. Checks the chunk buffer first, if |
|---|
| 153 | input chunking is enabled. Re-fills buffer is necessary." |
|---|
| 154 | (unless (chunked-stream-input-chunking-p stream) |
|---|
| 155 | (return-from stream-read-byte (read-byte (chunked-stream-stream stream) nil :eof))) |
|---|
| 156 | (unless (chunked-input-available-p stream) |
|---|
| 157 | (unless (fill-buffer stream) |
|---|
| 158 | (return-from stream-read-byte :eof))) |
|---|
| 159 | (with-slots (input-buffer input-index) |
|---|
| 160 | stream |
|---|
| 161 | (prog1 (aref input-buffer input-index) |
|---|
| 162 | (incf input-index)))) |
|---|
| 163 | |
|---|
| 164 | (defmethod stream-read-sequence ((stream chunked-input-stream) sequence start end &key) |
|---|
| 165 | "Fills SEQUENCE by adding data from the chunk buffer and re-filling |
|---|
| 166 | it until enough data was read. Works directly on the underlying |
|---|
| 167 | stream if input chunking is off." |
|---|
| 168 | (unless (chunked-stream-input-chunking-p stream) |
|---|
| 169 | (return-from stream-read-sequence |
|---|
| 170 | (read-sequence sequence (chunked-stream-stream stream) :start start :end end))) |
|---|
| 171 | (loop |
|---|
| 172 | (when (>= start end) |
|---|
| 173 | (return-from stream-read-sequence start)) |
|---|
| 174 | (unless (chunked-input-available-p stream) |
|---|
| 175 | (unless (fill-buffer stream) |
|---|
| 176 | (return-from stream-read-sequence start))) |
|---|
| 177 | (with-slots (input-buffer input-limit input-index) |
|---|
| 178 | stream |
|---|
| 179 | (replace sequence input-buffer |
|---|
| 180 | :start1 start :end1 end |
|---|
| 181 | :start2 input-index :end2 input-limit) |
|---|
| 182 | (let ((length (min (- input-limit input-index) |
|---|
| 183 | (- end start)))) |
|---|
| 184 | (incf start length) |
|---|
| 185 | (incf input-index length))))) |
|---|