pax_global_header00006660000000000000000000000064132221553510014511gustar00rootroot0000000000000052 comment=16330852d01dfde4dd97dee7cd985a88ea571e7e chunga-20180131-git/000077500000000000000000000000001322215535100140005ustar00rootroot00000000000000chunga-20180131-git/CHANGELOG000066400000000000000000000002061322215535100152100ustar00rootroot00000000000000Version 1.1.7 2017-12-31 Removed (safety 0) Version 1.1.6 2014-11-28 add CHANGELOG (Hans Huebner) update support info (Hans Huebner) chunga-20180131-git/CHANGELOG.txt000066400000000000000000000036101322215535100160300ustar00rootroot00000000000000Version 1.1.5 2013-03-21 Fixes to changed default for eof-error-p suggested by Edi Weitz Version 1.1.4 2013-03-20 Trivial documentation fix Version 1.1.3 2013-03-20 Change default eof-error-p in READ-CHAR* to T (reported by Xu Jingtao) Version 1.1.2 2012-12-09 Fix bug in READ-NAME-VALUE-PAIR for cookie reading in Drakma Version 1.1.1 2010-05-19 Read quoted cookie values (Red Daly) Version 1.1.0 2009-12-01 Exported TOKEN-CHAR-P Allowed START and END keyword arguments for TRIM-WHITESPACE Simplified cookie value parsing Version 1.0.0 2009-02-19 Switched to binary streams underneath and got rid of FLEXI-STREAMS dependency Added conditions Exported (an improved version of) AS-KEYWORD Added WITH-CHARACTER-STREAM-SEMANTICS Version 0.4.3 2008-05-23 Cleanup, reduce some consing Version 0.4.2 2008-05-07 Flush stream when switching chunking off (patch by Hans Hübner) Version 0.4.1 2007-10-11 Make Chunga work with AllegroCL's "modern" mode (patch by Ross Jekel) Version 0.4.0 2007-09-18 Added *TREAT-SEMICOLON-AS-CONTINUATION* Version 0.3.1 2007-09-07 Fixed bug in STREAM-LISTEN Version 0.3.0 2007-05-08 Added *ACCEPT-BOGUS-EOLS* (suggested by Sean Ross) Version 0.2.4 2007-02-08 Allow more characters in cookie names/values according to original Netscape spec Robustified READ-COOKIE-VALUE Version 0.2.3 2007-01-17 Guard against stray semicolons when reading name/value pairs (thanks to B?lent Murtezaoglu) Version 0.2.2 2007-01-10 Faster vesion of READ-LINE* (provided by Gabor Melis) Version 0.2.1 2006-10-26 Added explicit element types for CLISP to fix problems reported by Anton Vodonosov Version 0.2.0 2006-10-06 Only wrap inner stream with flexi stream if really needed Version 0.1.2 2006-09-05 Exported CHUNKED-STREAM-STREAM Mentioned Gentoo port in docs Added info about mailing lists Version 0.1.1 2006-09-02 Added missing CRLF for output chunking Version 0.1.0 2006-09-01 First public release chunga-20180131-git/chunga.asd000066400000000000000000000035611322215535100157430ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- ;;; $Header: /usr/local/cvsrep/chunga/chunga.asd,v 1.20 2008/05/24 18:38:30 edi Exp $ ;;; Copyright (c) 2006-2010, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE 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) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (asdf:defsystem :chunga :serial t :version "1.1.7" :depends-on (:trivial-gray-streams) :components ((:file "packages") (:file "specials") (:file "util") (:file "known-words") (:file "conditions") (:file "read") (:file "streams") (:file "input") (:file "output"))) chunga-20180131-git/conditions.lisp000066400000000000000000000072631322215535100170520ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: ODD-STREAMS; Base: 10 -*- ;;; $Header: /usr/local/cvsrep/odd-streams/conditions.lisp,v 1.5 2007/12/31 01:08:45 edi Exp $ ;;; Copyright (c) 2008-2010, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE 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) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package :chunga) (define-condition chunga-condition (condition) () (:documentation "Superclass for all conditions related to Chunga.")) (define-condition chunga-error (chunga-condition stream-error) () (:documentation "Superclass for all errors related to Chunga. This is a subtype of STREAM-ERROR, so STREAM-ERROR-STREAM can be used to access the offending stream.")) (define-condition chunga-simple-error (chunga-error simple-condition) () (:documentation "Like CHUNGA-ERROR but with formatting capabilities.")) (define-condition parameter-error (chunga-simple-error) () (:documentation "Signalled if a function was called with inconsistent or illegal parameters.")) (define-condition syntax-error (chunga-simple-error) () (:documentation "Signalled if Chunga encounters wrong or unknown syntax when reading data.")) (define-condition chunga-warning (chunga-condition warning) () (:documentation "Superclass for all warnings related to Chunga.")) (define-condition chunga-simple-warning (chunga-warning simple-condition) () (:documentation "Like CHUNGA-WARNING but with formatting capabilities.")) (define-condition input-chunking-unexpected-end-of-file (chunga-error) () (:documentation "A condition of this type is signaled if we reach an unexpected EOF on a chunked stream with input chunking enabled.")) (define-condition input-chunking-body-corrupted (chunga-error) ((last-char :initarg :last-char :documentation "The \(unexpected) character which was read.") (expected-chars :initarg :expected-chars :documentation "The characters which were expected. A list of characters or one single character.")) (:report (lambda (condition stream) (with-slots (last-char expected-chars) condition (format stream "Chunked stream ~S seems to be corrupted. Read character ~S, but expected ~:[a member of ~S~;~S~]." (stream-error-stream condition) last-char (atom expected-chars) expected-chars)))) (:documentation "A condition of this type is signaled if an unexpected character \(octet) is read while reading from a chunked stream with input chunking enabled.")) chunga-20180131-git/docs/000077500000000000000000000000001322215535100147305ustar00rootroot00000000000000chunga-20180131-git/docs/index.html000066400000000000000000000747361322215535100167460ustar00rootroot00000000000000 CHUNGA - Portable chunked streams for Common Lisp

CHUNGA - Portable chunked streams for Common Lisp


 

Abstract

Chunga implements streams capable of chunked encoding on demand as defined in RFC 2616. For an example of how these streams can be used see Drakma.

The library needs a Common Lisp implementation that supports Gray streams and relies on David Lichteblau's trivial-gray-streams to offer portability between different Lisps.

Chunga is currently not optimized towards performance - it is rather intended to be easy to use and (if possible) to behave correctly.

The code comes with a BSD-style license so you can basically do with it whatever you want.

Download current version or visit the project on Github.


 

Contents

  1. Download and installation
  2. Support
  3. The Chunga dictionary
    1. Chunked streams
      1. chunked-stream
      2. chunked-input-stream
      3. chunked-output-stream
      4. chunked-io-stream
      5. make-chunked-stream
      6. chunked-stream-stream
      7. chunked-stream-input-chunking-p
      8. chunked-stream-output-chunking-p
      9. chunked-input-stream-extensions
      10. chunked-input-stream-trailers
    2. Conditions
      1. chunga-condition
      2. chunga-error
      3. chunga-warning
      4. syntax-error
      5. parameter-error
      6. input-chunking-body-corrupted
      7. input-chunking-unexpected-end-of-file
    3. RFC 2616 parsing
      1. with-character-stream-semantics
      2. read-line*
      3. read-http-headers
      4. token-char-p
      5. read-token
      6. read-name-value-pair
      7. read-name-value-pairs
      8. assert-char
      9. skip-whitespace
      10. read-char*
      11. peek-char*
      12. trim-whitespace
      13. *current-error-message*
      14. *accept-bogus-eols*
      15. *treat-semicolon-as-continuation*
      16. as-keyword
      17. as-capitalized-string
  4. Acknowledgements

 

Download and installation

Chunga together with this documentation can be downloaded from Github. The current version is 1.1.7. Chunga will only work with Lisps where the character codes of all Latin-1 characters coincide with their Unicode code points (which is the case for all current implementations I know).

The esieast way to install Chunga is with Quicklisp

The current development version of Chunga can be found at https://github.com/edicl/chunga.
 

Support

The development version of chunga can be found on github. Please use the github issue tracking system to submit bug reports. Patches are welcome, please use GitHub pull requests.
 

The Chunga dictionary

Chunked streams

Chunked streams are the core of the Chunga library. You create them using the function MAKE-CHUNKED-STREAM which takes an open binary stream (called the underlying stream) as its single argument. A binary stream in this context means that if it's an input stream, you can apply READ-SEQUENCE to it where the sequence is an array of element type OCTET, and similarly for WRITE-SEQUENCE and output streams. (Note that this specifically holds for bivalent streams like socket streams.)

A chunked stream behaves like an ordinary Lisp stream of element type OCTET with the addition that you can turn chunking on and off for input as well as for output. With chunking turned on, data is read or written according to the definition in RFC 2616.


[Standard class]
chunked-stream


Every chunked stream returned by MAKE-CHUNKED-STREAM is of this type which is a subtype of STREAM.


[Standard class]
chunked-input-stream


A chunked stream is of this type if its underlying stream is an input stream. This is a subtype of CHUNKED-STREAM.


[Standard class]
chunked-output-stream


A chunked stream is of this type if its underlying stream is an output stream. This is a subtype of CHUNKED-STREAM.


[Standard class]
chunked-io-stream


A chunked stream is of this type if it is both a CHUNKED-INPUT-STREAM as well as a CHUNKED-OUTPUT-STREAM.


[Function]
make-chunked-stream stream => chunked-stream


Creates and returns a chunked stream (a stream of type CHUNKED-STREAM) which wraps stream. stream must be an open binary stream.


[Specialized reader]
chunked-stream-stream (stream chunked-stream) => underlying-stream


Returns the underlying stream of the chunked stream stream.


[Generic reader]
chunked-stream-input-chunking-p object => generalized-boolean


Returns a true value if object is of type CHUNKED-INPUT-STREAM and if input chunking is currently enabled.


[Specialized writer]
(setf (chunked-stream-input-chunking-p (stream chunked-input-stream)) new-value)


This function is used to switch input chunking on stream on or off. Note that input chunking will usally be turned off automatically when the last chunk is read.


[Generic reader]
chunked-stream-output-chunking-p object => generalized-boolean


Returns a true value if object is of type CHUNKED-OUTPUT-STREAM and if output chunking is currently enabled.


[Specialized writer]
(setf (chunked-stream-output-chunking-p (stream chunked-output-stream)) new-value)


This function is used to switch output chunking on stream on or off.


[Specialized reader]
chunked-input-stream-extensions (stream chunked-input-stream) => extensions


Returns an alist of attribute/value pairs corresponding to the optional "chunk extensions" which might have been encountered when reading from stream.


[Specialized reader]
chunked-input-stream-trailers (stream chunked-input-stream) => trailers


Returns the optional "trailer" HTTP headers which might have been sent after the last chunk, i.e. directly before input chunking ended on stream. The format of trailers is identical to that returned by READ-HTTP-HEADERS.

Conditions

Here are conditions which might be signalled if something bad happens with a chunked stream.


[Condition]
chunga-condition


All conditions signalled by Chunga are of this type. This is a subtype of CONDITION.


[Error]
chunga-error


All errors signalled by Chunga are of this type. This is a subtype of CHUNGA-CONDITION and of STREAM-ERROR, so STREAM-ERROR-STREAM can be used to access the offending stream.


[Warning]
chunga-warning


All warnings signalled by Chunga are of this type. This is a subtype of CHUNGA-CONDITION and of WARNING.


[Error]
syntax-error


An error of this type is signalled if Chunga encounters wrong or unknown syntax when reading data. This is a subtype of CHUNGA-ERROR.


[Error]
parameter-error


An error of this type is signalled if a function was called with inconsistent or illegal parameters. This is a subtype of CHUNGA-ERROR.


[Condition type]
input-chunking-body-corrupted


A condition of this type is signaled if an unexpected character (octet) is read while reading from a chunked stream with input chunking enabled. This is a subtype of CHUNGA-ERROR.


[Condition type]
input-chunking-unexpected-end-of-file


A condition of this type is signaled if we reach an unexpected EOF on a chunked stream with input chunking enabled. This is a subtype of CHUNGA-ERROR.

RFC 2616 parsing

Chunga needs to know a bit about RFC 2616 syntax in order to cope with extensions and trailers. As these functions are in there anyway, they're exported, so they can be used by other code like for example Drakma.

Note that all of these functions are designed to work on binary streams, specifically on streams with element type (UNSIGNED-BYTE 8). They will not work with character streams. (But the "bivalent" streams offered by many Lisp implementations will do.) They must be called within the context of WITH-CHARACTER-STREAM-SEMANTICS.


[Macro]
with-character-stream-semantics statement* => result*


Executes the statement* forms in such a way that functions within this section can read characters from binary streams (treating octets as the Latin-1 characters with the corresponding code points). All the functions below must be wrapped with this macro. If your code uses several of these functions which interact on the same stream, all of them must be wrapped with the same macro. See the source code of Drakma or Hunchentoot for examples of how to use this macro.


[Function]
read-line* stream &optional log-stream => line


Reads and assembles characters from the binary stream stream until a carriage return is read. Makes sure that the following character is a linefeed. If *ACCEPT-BOGUS-EOLS* is not NIL, then the function will also accept a lone carriage return or linefeed as a line break. Returns the string of characters read excluding the line break. Additionally logs this string to log-stream if it is not NIL.

See WITH-CHARACTER-STREAM-SEMANTICS.


[Function]
read-http-headers stream &optional log-stream => headers


Reads HTTP header lines from the binary stream stream (except for the initial status line which is supposed to be read already) and returns a corresponding alist of names and values where the names are keywords and the values are strings. Multiple lines with the same name are combined into one value, the individual values separated by commas. Header lines which are spread across multiple lines are recognized and treated correctly. (But see *TREAT-SEMICOLON-AS-CONTINUATION*.) Additonally logs the header lines to log-stream if it is not NIL.

See WITH-CHARACTER-STREAM-SEMANTICS.


[Function]
read-token stream => token


Read characters from the binary stream stream while they are token constituents (according to RFC 2616). It is assumed that there's a token character at the current position. The token read is returned as a string. Doesn't signal an error (but simply stops reading) if END-OF-FILE is encountered after the first character.

See WITH-CHARACTER-STREAM-SEMANTICS.


[Function]
token-char-p char => generalized-boolean


Returns a true value if the Lisp character char is a token constituent according to RFC 2616.


[Function]
read-name-value-pair stream &key value-required-p cookie-syntax => pair


Reads a typical (in RFC 2616) name/value or attribute/value combination from the binary stream stream - a token followed by a #\= character and another token or a quoted string. Returns a cons of the name and the value, both as strings. If value-required-p is NIL (the default is T), the #\= sign and the value are optional. If cookie-syntax is true (the default is NIL), the value is read like the value of a cookie header.

See WITH-CHARACTER-STREAM-SEMANTICS.


[Function]
read-name-value-pairs stream &key value-required-p cookie-syntax => pairs


Uses READ-NAME-VALUE-PAIR to read and return an alist of name/value pairs from the binary stream stream. It is assumed that the pairs are separated by semicolons and that the first char read (except for whitespace) will be a semicolon. The parameters are used as in READ-NAME-VALUE-PAIR. Stops reading in case of END-OF-FILE (instead of signaling an error).

See WITH-CHARACTER-STREAM-SEMANTICS.


[Function]
assert-char stream expected-char => char


Reads the next character from the binary stream stream and checks if it is the character expected-char. Signals an error otherwise.

See WITH-CHARACTER-STREAM-SEMANTICS.


[Function]
skip-whitespace stream => char-or-nil


Consume characters from the binary stream stream until an END-OF-FILE is encountered or a non-whitespace (according to RFC 2616) characters is seen. This character is returned (or NIL in case of END-OF-FILE).

See WITH-CHARACTER-STREAM-SEMANTICS.


[Function]
read-char* stream => char


Reads and returns the next character from the binary stream stream.

See WITH-CHARACTER-STREAM-SEMANTICS.


[Function]
peek-char* stream &optional eof-error-p eof-value => boolean


Returns a true value if a character can be read from the binary stream stream. If eof-error-p has a true value, an error is signalled if no character remains to be read. eof-value specifies the value to return if eof-error-p is false and the end of the file has been reached.

See WITH-CHARACTER-STREAM-SEMANTICS.


[Function]
trim-whitespace string &key start end => string'


Returns a version of the string string (between start and end) where spaces and tab characters are trimmed from the start and the end.


[Special variable]
*current-error-message*


Used by the parsing functions in this section as an introduction to a standardized error message. Should be bound to a string or NIL if one of these functions is called.


[Special variable]
*accept-bogus-eols*


Some web servers do not respond with a correct CRLF line ending for HTTP headers but with a lone linefeed or carriage return instead. If this variable is bound to a true value, READ-LINE* will treat a lone LF or CR character as an acceptable end of line. The initial value is NIL.


[Special variable]
*treat-semicolon-as-continuation*


According to John Foderaro, Netscape v3 web servers bogusly split Set-Cookie headers over multiple lines which means that we'd have to treat Set-Cookie headers ending with a semicolon as incomplete and combine them with the next header. This will only be done if this variable has a true value, though. Its default value is NIL.


[Function]
as-keyword string &key destructivep => keyword


Converts the string string to a keyword where all characters are uppercase or lowercase, taking into account the current readtable case. Might destructively modify string if destructivep is true which is the default. "Knows" several HTTP header names and methods and is optimized to not call INTERN for these.


[Function]
as-capitalized-string keyword => capitalized-string


Kind of the inverse of AS-KEYWORD. Has essentially the same effect as STRING-CAPITALIZE but is optimized for "known" keywords like :CONTENT-LENGTH or :GET.

 

Acknowledgements

Thanks to Jochen Schmidt's chunking code in ACL-COMPAT for inspiration. This documentation was prepared with DOCUMENTATION-TEMPLATE.

chunga-20180131-git/input.lisp000066400000000000000000000214201322215535100160270ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CHUNGA; Base: 10 -*- ;;; $Header: /usr/local/cvsrep/chunga/input.lisp,v 1.18 2008/05/24 03:06:22 edi Exp $ ;;; Copyright (c) 2006-2010, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE 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) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package :chunga) (defmethod chunked-input-stream-extensions ((object t)) "The default method which always returns the empty list." nil) (defmethod chunked-input-stream-trailers ((object t)) "The default method which always returns the empty list." nil) (defmethod chunked-stream-input-chunking-p ((object t)) "The default method for all objects which are not of type CHUNKED-INPUT-STREAM." nil) (defmethod (setf chunked-stream-input-chunking-p) (new-value (stream chunked-input-stream)) "Switches input chunking for STREAM on or off." (unless (eq (not new-value) (not (chunked-stream-input-chunking-p stream))) (with-slots (input-limit input-index expecting-crlf-p chunk-extensions chunk-trailers) stream (cond (new-value (setq expecting-crlf-p nil input-limit 0 input-index 0 chunk-extensions nil chunk-trailers nil)) (t (when (< input-index input-limit) (error 'parameter-error :stream stream :format-control "Not all chunks from ~S have been read completely." :format-arguments (list stream))))))) (setf (slot-value stream 'input-chunking-p) new-value)) (defmethod stream-clear-input ((stream chunked-input-stream)) "Implements CLEAR-INPUT by resetting the internal chunk buffer." (when (chunked-stream-input-chunking-p stream) (setf (chunked-stream-input-index stream) 0 (chunked-stream-input-limit stream) 0)) ;; clear input on inner stream (clear-input (chunked-stream-stream stream)) nil) (defmethod chunked-input-available-p ((stream chunked-input-stream)) "Whether there's unread input waiting in the chunk buffer." (< (chunked-stream-input-index stream) (chunked-stream-input-limit stream))) (defmethod stream-listen ((stream chunked-input-stream)) "We first check if input chunking is enabled and if there's something in the buffer. Otherwise we poll the underlying stream." (cond ((chunked-stream-input-chunking-p stream) (or (chunked-input-available-p stream) (fill-buffer stream))) (t (listen (chunked-stream-stream stream))))) (defmethod fill-buffer ((stream chunked-input-stream)) "Re-fills the chunk buffer. Returns NIL if chunking has ended." (let ((inner-stream (chunked-stream-stream stream)) ;; set up error function for the functions in `read.lisp' (*current-error-function* (lambda (last-char expected-chars) "The function which is called when an unexpected character is seen. Signals INPUT-CHUNKING-BODY-CORRUPTED." (error 'input-chunking-body-corrupted :stream stream :last-char last-char :expected-chars expected-chars)))) (labels ((add-extensions () "Reads chunk extensions \(if there are any) and stores them into the corresponding slot of the stream." (when-let (extensions (read-name-value-pairs inner-stream)) (warn 'chunga-warning :stream stream :format-control "Adding uninterpreted extensions to stream ~S." :format-arguments (list stream)) (setf (slot-value stream 'chunk-extensions) (append (chunked-input-stream-extensions stream) extensions))) (assert-crlf inner-stream)) (get-chunk-size () "Reads chunk size header \(including optional extensions) and returns the size." (with-character-stream-semantics (when (expecting-crlf-p stream) (assert-crlf inner-stream)) (setf (expecting-crlf-p stream) t) ;; read hexadecimal number (let (last-char) (prog1 (loop for weight = (digit-char-p (setq last-char (read-char* inner-stream)) 16) for result = (if weight (+ weight (* 16 (or result 0))) (return (or result (error 'input-chunking-body-corrupted :stream stream :last-char last-char :expected-chars +hex-digits+))))) ;; unread first octet which wasn't a digit (unread-char* last-char) (add-extensions)))))) (let ((chunk-size (get-chunk-size))) (with-slots (input-buffer input-limit input-index) stream (setq input-index 0 input-limit chunk-size) (cond ((zerop chunk-size) ;; turn chunking off (setf (chunked-stream-input-chunking-p stream) nil (slot-value stream 'chunk-trailers) (with-character-stream-semantics (read-http-headers inner-stream)) input-limit 0) ;; return NIL (return-from fill-buffer)) ((> chunk-size (length input-buffer)) ;; replace buffer if it isn't big enough for the next chunk (setq input-buffer (make-array chunk-size :element-type '(unsigned-byte 8))))) (unless (= (read-sequence input-buffer inner-stream :start 0 :end chunk-size) chunk-size) (error 'input-chunking-unexpected-end-of-file :stream stream)) chunk-size))))) (defmethod stream-read-byte ((stream chunked-input-stream)) "Reads one byte from STREAM. Checks the chunk buffer first, if input chunking is enabled. Re-fills buffer is necessary." (unless (chunked-stream-input-chunking-p stream) (return-from stream-read-byte (read-byte (chunked-stream-stream stream) nil :eof))) (unless (chunked-input-available-p stream) (unless (fill-buffer stream) (return-from stream-read-byte :eof))) (with-slots (input-buffer input-index) stream (prog1 (aref input-buffer input-index) (incf input-index)))) (defmethod stream-read-sequence ((stream chunked-input-stream) sequence start end &key) "Fills SEQUENCE by adding data from the chunk buffer and re-filling it until enough data was read. Works directly on the underlying stream if input chunking is off." (unless (chunked-stream-input-chunking-p stream) (return-from stream-read-sequence (read-sequence sequence (chunked-stream-stream stream) :start start :end end))) (loop (when (>= start end) (return-from stream-read-sequence start)) (unless (chunked-input-available-p stream) (unless (fill-buffer stream) (return-from stream-read-sequence start))) (with-slots (input-buffer input-limit input-index) stream (replace sequence input-buffer :start1 start :end1 end :start2 input-index :end2 input-limit) (let ((length (min (- input-limit input-index) (- end start)))) (incf start length) (incf input-index length))))) chunga-20180131-git/known-words.lisp000066400000000000000000000114111322215535100171570ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CHUNGA; Base: 10 -*- ;;; $Header: /usr/local/cvsrep/chunga/known-words.lisp,v 1.3 2008/05/29 22:21:09 edi Exp $ ;;; Copyright (c) 2006-2010, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE 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) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package :chunga) (eval-when (:compile-toplevel :load-toplevel :execute) (define-constant +known-words+ '(;; headers including WebDAV and some de facto standard headers "Accept" "Accept-Charset" "Accept-Encoding" "Accept-Language" "Accept-Ranges" "Age" "Allow" "Authorization" "Cache-Control" "Connection" "Content-Encoding" "Content-Language" "Content-Length" "Content-Location" "Content-MD5" "Content-Range" "Content-Type" "DAV" "Date" "Depth" "Destination" "ETag" "Expect" "Expires" "From" "Host" "If" "If-Match" "If-Modified-Since" "If-None-Match" "If-Range" "If-Unmodified-Since" "Last-Modified" "Location" "Lock-Token" "Max-Forwards" "Overwrite" "Pragma" "Proxy-Authenticate" "Proxy-Authorization" "Range" "Referer" "Retry-After" "Server" "TE" "TimeOut" "Trailer" "Transfer-Encoding" "Upgrade" "User-Agent" "Vary" "Via" "WWW-Authenticate" "Warning" ;; methods including WebDAV "CONNECT" "COPY" "DELETE" "GET" "HEAD" "LOCK" "MKCOL" "MOVE" "OPTIONS" "POST" "PROPFIND" "PROPPATCH" "PUT" "TRACE" "UNLOCK" ;; protocols "HTTP/1.1" "HTTP/1.0" ;; only a few and only the "preferred MIME names" - see ;; for a ;; complete list "US-ASCII" "ISO-8859-1" "UTF-8" "UTF-16" "UTF-32BE" "UTF-32LE") "A list of words \(headers, methods, protocols, character sets) that are typically seen in HTTP communication. Mostly from RFC 2616, but includes WebDAV stuff and other things as well.")) (define-constant +string-to-keyword-hash+ (let ((hash (make-hash-table :test 'equal :size (length +known-words+)))) (loop for word in +known-words+ do (setf (gethash word hash) (make-keyword word nil))) hash) "A hash table which case-insensitively maps the strings from +KNOWN-WORDS+ to keywords.") (define-constant +keyword-to-string-hash+ (let ((hash (make-hash-table :test 'eq :size (length +known-words+)))) (loop for word in +known-words+ do (setf (gethash (make-keyword word nil) hash) (string-capitalize word))) hash) "A hash table which maps keywords derived from +KNOWN-WORDS+ to capitalized strings.") (defun as-keyword (string &key (destructivep t)) "Converts the string STRING to a keyword where all characters are uppercase or lowercase, taking into account the current readtable case. Might destructively modify STRING if DESTRUCTIVEP is true which is the default. \"Knows\" several HTTP header names and methods and is optimized to not call INTERN for these." (or (gethash string +string-to-keyword-hash+) (make-keyword string destructivep))) (defun as-capitalized-string (keyword) "Kind of the inverse of AS-KEYWORD. Has essentially the same effect as STRING-CAPITALIZE but is optimized for \"known\" keywords like :CONTENT-LENGTH or :GET." (or (gethash keyword +keyword-to-string-hash+) (string-capitalize keyword))) chunga-20180131-git/output.lisp000066400000000000000000000135221322215535100162340ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CHUNGA; Base: 10 -*- ;;; $Header: /usr/local/cvsrep/chunga/output.lisp,v 1.14 2008/05/24 03:06:22 edi Exp $ ;;; Copyright (c) 2006-2010, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE 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) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package :chunga) (defmethod chunked-stream-output-chunking-p ((object t)) "The default method for all objects which are not of type CHUNKED-OUTPUT-STREAM." nil) (defmethod write-chunk ((stream chunked-output-stream) sequence &key (start 0) (end (length sequence))) "Writes the contents of SEQUENCE from START to END to the underlying stream of STREAM as one chunk." (let ((output-stream (chunked-stream-stream stream))) ;; chunk size (loop for char across (format nil "~X" (- end start)) do (write-byte (char-code char) output-stream)) (write-sequence +crlf+ output-stream) ;; data (write-sequence sequence output-stream :start start :end end) (write-sequence +crlf+ output-stream))) (defmethod flush-buffer ((stream chunked-output-stream)) "Uses WRITE-CHUNK to empty the output buffer unless it is already empty." (with-slots (output-buffer output-index) stream (when (plusp output-index) (write-chunk stream output-buffer :end output-index) (setq output-index 0)))) (defmethod (setf chunked-stream-output-chunking-p) (new-value (stream chunked-output-stream)) "Switches output chunking for STREAM on or off." (unless (eq (not new-value) (not (chunked-stream-output-chunking-p stream))) (with-slots (real-stream output-index) stream (cond (new-value ;; get rid of "old" data (force-output real-stream) ;; initialize output buffer as being empty (setq output-index 0)) (t (flush-buffer stream) ;; last chunk to signal end of chunking (write-byte #.(char-code #\0) real-stream) (write-sequence +crlf+ real-stream) (write-sequence +crlf+ real-stream) (force-output real-stream))))) (setf (slot-value stream 'output-chunking-p) new-value)) (defmethod stream-clear-output ((stream chunked-output-stream)) "We clear output by resetting the output buffer and clearing the underlying stream." (when (chunked-stream-output-chunking-p stream) (setf (slot-value stream 'output-index) 0)) (clear-output (chunked-stream-stream stream))) (defmethod stream-finish-output ((stream chunked-output-stream)) "Flush the output buffer if output chunking is on, then operate on the underlying stream." (when (chunked-stream-output-chunking-p stream) (flush-buffer stream)) (finish-output (chunked-stream-stream stream))) (defmethod stream-force-output ((stream chunked-output-stream)) "Flush the output buffer if output chunking is on, then operate on the underlying stream." (when (chunked-stream-output-chunking-p stream) (flush-buffer stream)) (force-output (chunked-stream-stream stream))) (defmethod stream-write-byte ((stream chunked-output-stream) byte) "Writes one byte by simply adding it to the end of the output buffer \(if output chunking is enabled). The buffer is flushed if necessary." (unless (chunked-stream-output-chunking-p stream) (return-from stream-write-byte (write-byte byte (chunked-stream-stream stream)))) (with-slots (output-index output-buffer) stream (when (>= output-index +output-buffer-size+) (flush-buffer stream)) (setf (aref output-buffer output-index) byte) (incf output-index) byte)) (defmethod stream-write-sequence ((stream chunked-output-stream) sequence start end &key) "Outputs SEQUENCE by appending it to the output buffer if it's small enough. Large sequences are written directly using WRITE-CHUNK." (unless (chunked-stream-output-chunking-p stream) (return-from stream-write-sequence (write-sequence sequence (chunked-stream-stream stream) :start start :end end))) (with-slots (output-buffer output-index) stream (let ((length (- end start))) (cond ((<= length (- +output-buffer-size+ output-index)) (replace output-buffer sequence :start1 output-index :start2 start :end2 end) (incf output-index length)) (t (flush-buffer stream) (write-chunk stream sequence :start start :end end))))) sequence) (defmethod close ((stream chunked-output-stream) &key abort) "When a stream is closed and ABORT isn't true we have to make sure to send the last chunk." (unless abort (setf (chunked-stream-output-chunking-p stream) nil)) (call-next-method)) chunga-20180131-git/packages.lisp000066400000000000000000000052111322215535100164460ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- ;;; $Header: /usr/local/cvsrep/chunga/packages.lisp,v 1.19 2008/05/24 18:38:30 edi Exp $ ;;; Copyright (c) 2006-2010, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE 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) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package :cl-user) (defpackage :chunga (:use :cl :trivial-gray-streams) #+:lispworks (:import-from :lw :when-let) (:export :*accept-bogus-eols* :*current-error-message* :*treat-semicolon-as-continuation* :assert-char :as-keyword :as-capitalized-string :chunga-error :chunga-warning :chunked-input-stream :chunked-input-stream-extensions :chunked-input-stream-trailers :chunked-io-stream :chunked-output-stream :chunked-stream :chunked-stream-input-chunking-p :chunked-stream-output-chunking-p :chunked-stream-stream :input-chunking-body-corrupted :input-chunking-unexpected-end-of-file :make-chunked-stream :read-http-headers :peek-char* :read-char* :read-line* :read-name-value-pair :read-name-value-pairs :read-token :skip-whitespace :syntax-error :token-char-p :trim-whitespace :with-character-stream-semantics)) chunga-20180131-git/read.lisp000066400000000000000000000327061322215535100156140ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CHUNGA; Base: 10 -*- ;;; $Header: /usr/local/cvsrep/chunga/read.lisp,v 1.22 2008/05/26 08:18:00 edi Exp $ ;;; Copyright (c) 2006-2010, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE 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) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package :chunga) (defun signal-unexpected-chars (stream last-char expected-chars) "Signals an error that LAST-CHAR was read although one of EXPECTED-CHARS was expected. \(Note that EXPECTED-CHARS, despite its name, can also be a single character instead of a list). Calls *CURRENT-ERROR-FUNCTION* if it's not NIL, or uses *CURRENT-ERROR-MESSAGE* otherwise." (cond (*current-error-function* (funcall *current-error-function* last-char expected-chars)) (t (error 'syntax-error :stream stream :format-control "~@[~A~%~]~:[End of file~;Read character ~:*~S~], ~ but expected ~:[a member of ~S~;~S~]." :format-arguments (list *current-error-message* last-char (atom expected-chars) expected-chars))))) (defun charp (char) "Returns true if the Lisp character CHAR is a CHAR according to RFC 2616." (<= 0 (char-code char) 127)) (defun controlp (char) "Returns true if the Lisp character CHAR is a CTL according to RFC 2616." (or (<= 0 (char-code char) 31) (= (char-code char) 127))) (defun separatorp (char) "Returns true if the Lisp character CHAR is a separator according to RFC 2616." (find char #.(format nil " ()<>@,;:\\\"/[]?={}~C" #\Tab) :test #'char=)) (defun whitespacep (char) "Returns true if the Lisp character CHAR is whitespace according to RFC 2616." (member char '(#\Space #\Tab) :test #'char=)) (defun token-char-p (char) "Returns true if the Lisp character CHAR is a token constituent according to RFC 2616." (and (charp char) (not (or (controlp char) (separatorp char))))) (defun assert-char (stream expected-char) "Reads the next character from STREAM and checks if it is the character EXPECTED-CHAR. Signals an error otherwise." (let ((char (read-char* stream))) (unless (char= char expected-char) (signal-unexpected-chars stream char expected-char)) char)) (defun assert-crlf (stream) "Reads the next two characters from STREAM and checks if these are a carriage return and a linefeed. Signals an error otherwise." (assert-char stream #\Return) (assert-char stream #\Linefeed)) (defun read-line* (stream &optional log-stream) "Reads and assembles characters from the binary stream STREAM until a carriage return is read. Makes sure that the following character is a linefeed. If *ACCEPT-BOGUS-EOLS* is not NIL, then the function will also accept a lone carriage return or linefeed as an acceptable line break. Returns the string of characters read excluding the line break. Returns NIL if input ends before one character was read. Additionally logs this string to LOG-STREAM if it is not NIL." (let ((result (with-output-to-string (line) (loop for char-seen-p = nil then t for char = (read-char* stream nil) for is-cr-p = (and char (char= char #\Return)) until (or (null char) is-cr-p (and *accept-bogus-eols* (char= char #\Linefeed))) do (write-char char line) finally (cond ((and (not char-seen-p) (null char)) (return-from read-line* nil)) ((not *accept-bogus-eols*) (assert-char stream #\Linefeed)) (is-cr-p (when (eql (peek-char* stream) #\Linefeed) (read-char* stream)))))))) (when log-stream (write-line result log-stream) (finish-output log-stream)) result)) (defun trim-whitespace (string &key (start 0) (end (length string))) "Returns a version of the string STRING \(between START and END) where spaces and tab characters are trimmed from the start and the end. Might return STRING." ;; optimized version to replace STRING-TRIM, suggested by Jason Kantz (declare (optimize speed (space 0) (debug 1) (compilation-speed 0) #+:lispworks (hcl:fixnum-safety 0))) (declare (string string)) (let* ((start% (loop for i of-type fixnum from start below end while (or (char= #\space (char string i)) (char= #\tab (char string i))) finally (return i))) (end% (loop for i of-type fixnum downfrom (1- end) to start while (or (char= #\space (char string i)) (char= #\tab (char string i))) finally (return (1+ i))))) (declare (fixnum start% end%)) (cond ((and (zerop start%) (= end% (length string))) string) ((> start% end%) "") (t (subseq string start% end%))))) (defun read-http-headers (stream &optional log-stream) "Reads HTTP header lines from STREAM \(except for the initial status line which is supposed to be read already) and returns a corresponding alist of names and values where the names are keywords and the values are strings. Multiple lines with the same name are combined into one value, the individual values separated by commas. Header lines which are spread across multiple lines are recognized and treated correctly. Additonally logs the header lines to LOG-STREAM if it is not NIL." (let (headers (*current-error-message* "While reading HTTP headers:")) (labels ((read-header-line () "Reads one header line, considering continuations." (with-output-to-string (header-line) (loop (let ((line (trim-whitespace (read-line* stream log-stream)))) (when (zerop (length line)) (return)) (write-sequence line header-line) (let ((next (peek-char* stream))) (unless (whitespacep next) (return))) ;; we've seen whitespace starting a continutation, ;; so we loop (write-char #\Space header-line))))) (split-header (line) "Splits line at colon and converts it into a cons. Returns NIL if LINE consists solely of whitespace." (unless (zerop (length (trim-whitespace line))) (let ((colon-pos (or (position #\: line :test #'char=) (error 'syntax-error :stream stream :format-control "Couldn't find colon in header line ~S." :format-arguments (list line))))) (cons (as-keyword (subseq line 0 colon-pos)) (trim-whitespace (subseq line (1+ colon-pos))))))) (add-header (pair) "Adds the name/value cons PAIR to HEADERS. Takes care of multiple headers with the same name." (let* ((name (car pair)) (existing-header (assoc name headers :test #'eq)) (existing-value (cdr existing-header))) (cond (existing-header (setf (cdr existing-header) (format nil "~A~:[,~;~]~A" existing-value (and *treat-semicolon-as-continuation* (eq name :set-cookie) (ends-with-p (trim-whitespace existing-value) ";")) (cdr pair)))) (t (push pair headers)))))) (loop for header-pair = (split-header (read-header-line)) while header-pair do (add-header header-pair))) (nreverse headers))) (defun skip-whitespace (stream) "Consume characters from STREAM until an END-OF-FILE is encountered or a non-whitespace \(according to RFC 2616) characters is seen. This character is returned \(or NIL in case of END-OF-FILE)." (loop for char = (peek-char* stream nil) while (and char (whitespacep char)) do (read-char* stream) finally (return char))) (defun read-token (stream) "Read characters from STREAM while they are token constituents \(according to RFC 2616). It is assumed that there's a token character at the current position. The token read is returned as a string. Doesn't signal an error \(but simply stops reading) if END-OF-FILE is encountered after the first character." (with-output-to-string (out) (loop for first = t then nil for char = (if first (peek-char* stream) (or (peek-char* stream nil) (return))) while (token-char-p char) do (write-char (read-char* stream) out)))) (defun read-quoted-string (stream) "Reads a quoted string \(according to RFC 2616). It is assumed that the character at the current position is the opening quote character. Returns the string read without quotes and escape characters." (read-char* stream) (with-output-to-string (out) (loop for char = (read-char* stream) until (char= char #\") do (case char (#\\ (write-char (read-char* stream) out)) (#\Return (assert-char stream #\Linefeed) (let ((char (read-char* stream))) (unless (whitespacep char) (signal-unexpected-chars stream char '(#\Space #\Tab))))) (otherwise (write-char char out)))))) (defun read-cookie-value (stream &key (separators ";")) "Reads a cookie parameter value from STREAM which is returned as a string. Simply reads until a semicolon is seen \(or an element of SEPARATORS). Also reads quoted strings if the first non-whitespace character is a quotation mark \(as in RFC 2109)." (if (char= #\" (peek-char* stream)) (read-quoted-string stream) (trim-whitespace (with-output-to-string (out) (loop for char = (peek-char* stream nil) until (or (null char) (find char separators :test #'char=)) do (write-char (read-char* stream) out)))))) (defun read-name-value-pair (stream &key (value-required-p t) cookie-syntax) "Reads a typical \(in RFC 2616) name/value or attribute/value combination from STREAM - a token followed by a #\\= character and another token or a quoted string. Returns a cons of name and value, both as strings. If VALUE-REQUIRED-P is NIL, the #\\= sign and the value are optional. If COOKIE-SYNTAX is true, uses READ-COOKIE-VALUE internally." (skip-whitespace stream) (let ((name (if cookie-syntax (read-cookie-value stream :separators "=;") (read-token stream)))) (skip-whitespace stream) (cons name (when (or value-required-p (eql (peek-char* stream nil) #\=)) (assert-char stream #\=) (skip-whitespace stream) (cond (cookie-syntax (read-cookie-value stream)) ((char= (peek-char* stream) #\") (read-quoted-string stream)) (t (read-token stream))))))) (defun read-name-value-pairs (stream &key (value-required-p t) cookie-syntax) "Uses READ-NAME-VALUE-PAIR to read and return an alist of name/value pairs from STREAM. It is assumed that the pairs are separated by semicolons and that the first char read \(except for whitespace) will be a semicolon. The parameters are used as in READ-NAME-VALUE-PAIR. Stops reading in case of END-OF-FILE \(instead of signaling an error)." (loop for char = (skip-whitespace stream) while (and char (char= char #\;)) do (read-char* stream) ;; guard against a stray semicolon at the end when (skip-whitespace stream) collect (read-name-value-pair stream :value-required-p value-required-p :cookie-syntax cookie-syntax))) chunga-20180131-git/specials.lisp000066400000000000000000000100541322215535100164740ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CHUNGA; Base: 10 -*- ;;; $Header: /usr/local/cvsrep/chunga/specials.lisp,v 1.12 2008/05/24 03:06:22 edi Exp $ ;;; Copyright (c) 2006-2010, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE 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) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package :chunga) (defmacro define-constant (name value &optional doc) "A version of DEFCONSTANT for, cough, /strict/ CL implementations." ;; See `(defconstant ,name (if (boundp ',name) (symbol-value ',name) ,value) ,@(when doc (list doc)))) #+:lispworks (editor:setup-indent "define-constant" 1 2 4) (defconstant +output-buffer-size+ 8192 "Size of the initial output buffer for chunked output.") (define-constant +crlf+ (make-array 2 :element-type '(unsigned-byte 8) :initial-contents (mapcar 'char-code '(#\Return #\Linefeed))) "A 2-element array consisting of the character codes for a CRLF sequence.") (define-constant +hex-digits+ '#.(coerce "0123456789ABCDEF" 'list) "The hexadecimal digits.") (defvar *current-error-message* nil "Used by the parsing functions in `read.lisp' as an introduction to a standardized error message about unexpected characters unless it is NIL.") (defvar *current-error-function* nil "Used by the functions in `read.lisp' as a function to signal errors about unexpected characters when *CURRENT-ERROR-MESSAGE* is NIL.") (defvar *accept-bogus-eols* nil "Some web servers do not respond with a correct CRLF line ending for HTTP headers but with a lone linefeed or carriage return instead. If this variable is bound to a true value, READ-LINE* will treat a lone LF or CR character as an acceptable end of line. The initial value is NIL.") (defvar *treat-semicolon-as-continuation* nil "According to John Foderaro, Netscape v3 web servers bogusly split Set-Cookie headers over multiple lines which means that we'd have to treat Set-Cookie headers ending with a semicolon as incomplete and combine them with the next header. This will only be done if this variable has a true value, though.") (defvar *char-buffer* nil "A `buffer' for one character. Used by PEEK-CHAR* and UNREAD-CHAR*.") (pushnew :chunga *features*) ;; stuff for Nikodemus Siivola's HYPERDOC ;; see ;; and ;; also used by LW-ADD-ONS (defvar *hyperdoc-base-uri* "http://weitz.de/chunga/") (let ((exported-symbols-alist (loop for symbol being the external-symbols of :chunga collect (cons symbol (concatenate 'string "#" (string-downcase symbol)))))) (defun hyperdoc-lookup (symbol type) (declare (ignore type)) (cdr (assoc symbol exported-symbols-alist :test #'eq)))) chunga-20180131-git/streams.lisp000066400000000000000000000137221322215535100163540ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CHUNGA; Base: 10 -*- ;;; $Header: /usr/local/cvsrep/chunga/streams.lisp,v 1.10 2008/05/24 03:06:22 edi Exp $ ;;; Copyright (c) 2006-2010, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE 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) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package :chunga) (defclass chunked-stream (trivial-gray-stream-mixin) ((real-stream :initarg :real-stream :reader chunked-stream-stream :documentation "The actual stream that's used for input and/or output.")) (:documentation "Every chunked stream returned by MAKE-CHUNKED-STREAM is of this type which is a subtype of STREAM.")) (defclass chunked-input-stream (chunked-stream fundamental-binary-input-stream) ((input-chunking-p :initform nil :reader chunked-stream-input-chunking-p :documentation "Whether input chunking is currently enabled.") (input-buffer :initform nil :documentation "A vector containing the binary data from the most recent chunk that was read.") (input-index :initform 0 :accessor chunked-stream-input-index :documentation "The current position within INPUT-BUFFER.") (input-limit :initform 0 :accessor chunked-stream-input-limit :documentation "Only the content in INPUT-BUFFER up to INPUT-LIMIT belongs to the current chunk.") (chunk-extensions :initform nil :reader chunked-input-stream-extensions :documentation "An alist of attribute/value pairs corresponding to the optional `chunk extensions' which might be encountered when reading from a chunked stream.") (chunk-trailers :initform nil :reader chunked-input-stream-trailers :documentation "An alist of attribute/value pairs corresponding to the optional `trailer' HTTP headers which might be encountered at the end of a chunked stream.") (expecting-crlf-p :initform nil :accessor expecting-crlf-p :documentation "Whether we expect to see CRLF before we can read the next chunk-size header part from the stream. \(This will actually be the CRLF from the end of the last chunk-data part.)")) (:documentation "A chunked stream is of this type if its underlying stream is an input stream. This is a subtype of CHUNKED-STREAM.")) (defclass chunked-output-stream (chunked-stream fundamental-binary-output-stream) ((output-chunking-p :initform nil :reader chunked-stream-output-chunking-p :documentation "Whether output chunking is currently enabled.") (output-buffer :initform (make-array +output-buffer-size+ :element-type '(unsigned-byte 8)) :accessor output-buffer :documentation "A vector used to temporarily store data which will output in one chunk.") (output-index :initform 0 :accessor output-index :documentation "The current end of OUTPUT-BUFFER.")) (:documentation "A chunked stream is of this type if its underlying stream is an output stream. This is a subtype of CHUNKED-STREAM.")) (defclass chunked-io-stream (chunked-input-stream chunked-output-stream) () (:documentation "A chunked stream is of this type if it is both a CHUNKED-INPUT-STREAM as well as a CHUNKED-OUTPUT-STREAM.")) (defmethod stream-element-type ((stream chunked-stream)) "Chunked streams are always binary streams. Wrap them with flexi streams if you need a character stream." '(unsigned-byte 8)) (defmethod open-stream-p ((stream chunked-stream)) "A chunked stream is open if its underlying stream is open." (open-stream-p (chunked-stream-stream stream))) (defmethod close ((stream chunked-stream) &key abort) "If a chunked stream is closed, we close the underlying stream as well." (with-slots (real-stream) stream (cond ((open-stream-p real-stream) (close real-stream :abort abort)) (t nil)))) (defun make-chunked-stream (stream) "Creates and returns a chunked stream \(a stream of type CHUNKED-STREAM) which wraps STREAM. STREAM must be an open binary stream." (unless (and (streamp stream) (open-stream-p stream)) (error 'parameter-error :stream stream :format-control "~S should have been an open stream." :format-arguments (list stream))) (make-instance ;; actual type depends on STREAM (cond ((and (input-stream-p stream) (output-stream-p stream)) 'chunked-io-stream) ((input-stream-p stream) 'chunked-input-stream) ((output-stream-p stream) 'chunked-output-stream)) :real-stream stream))chunga-20180131-git/util.lisp000066400000000000000000000075311322215535100156540ustar00rootroot00000000000000;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CHUNGA; Base: 10 -*- ;;; $Header: /usr/local/cvsrep/chunga/util.lisp,v 1.12 2008/05/25 10:53:48 edi Exp $ ;;; Copyright (c) 2006-2010, Dr. Edmund Weitz. All rights reserved. ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; * Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; * 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 BY THE AUTHOR 'AS IS' AND ANY EXPRESSED ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE 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) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (in-package :chunga) #-:lispworks (defmacro when-let ((var expr) &body body) "Evaluates EXPR, binds it to VAR, and executes BODY if VAR has a true value." `(let ((,var ,expr)) (when ,var ,@body))) (defun ends-with-p (seq suffix &key (test #'char-equal)) "Returns true if the sequence SEQ ends with the sequence SUFFIX. Individual elements are compared with TEST." (let ((mismatch (mismatch seq suffix :from-end t :test test))) (or (null mismatch) (= mismatch (- (length seq) (length suffix)))))) (defun make-keyword (string destructivep) "Converts the string STRING to a keyword where all characters are uppercase or lowercase, taking into account the current readtable case. Destructively modifies STRING if DESTRUCTIVEP is true." (intern (funcall (if destructivep (if (eq (readtable-case *readtable*) :upcase) #'nstring-upcase #'nstring-downcase) (if (eq (readtable-case *readtable*) :upcase) #'string-upcase #'string-downcase)) string) :keyword)) (defun read-char* (stream &optional (eof-error-p t) eof-value) "The streams we're dealing with are all binary with element type \(UNSIGNED-BYTE 8) and we're only interested in ISO-8859-1, so we use this to `simulate' READ-CHAR." (cond (*char-buffer* (prog1 *char-buffer* (setq *char-buffer* nil))) (t ;; this assumes that character codes are identical to Unicode code ;; points, at least for Latin1 (let ((char-code (read-byte stream eof-error-p eof-value))) (and char-code (code-char char-code)))))) (defun unread-char* (char) "Were simulating UNREAD-CHAR by putting the character into *CHAR-BUFFER*." ;; no error checking, only used internally (setq *char-buffer* char) nil) (defun peek-char* (stream &optional eof-error-p eof-value) "We're simulating PEEK-CHAR by reading a character and putting it into *CHAR-BUFFER*." ;; no error checking, only used internally (setq *char-buffer* (read-char* stream eof-error-p eof-value))) (defmacro with-character-stream-semantics (&body body) "Binds *CHAR-BUFFER* around BODY so that within BODY we can use READ-CHAR* and friends \(see above) to simulate a character stream although we're reading from a binary stream." `(let ((*char-buffer* nil)) ,@body))