Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Branch: master
Fetching contributors…

Cannot retrieve contributors at this time

288 lines (212 sloc) 8.821 kB
;; -*- mode: common-lisp; package: net.aserve -*-
;;
;; chunker.cl
;;
;; copyright (c) 1986-2005 Franz Inc, Berkeley, CA - All rights reserved.
;; copyright (c) 2000-2012 Franz Inc, Oakland, CA - All rights reserved.
;;
;; This code is free software; you can redistribute it and/or
;; modify it under the terms of the version 2.1 of
;; the GNU Lesser General Public License as published by
;; the Free Software Foundation, as clarified by the AllegroServe
;; prequel found in license-allegroserve.txt.
;;
;; This code is distributed in the hope that it will be useful,
;; but without any warranty; without even the implied warranty of
;; merchantability or fitness for a particular purpose. See the GNU
;; Lesser General Public License for more details.
;;
;; Version 2.1 of the GNU Lesser General Public License is in the file
;; license-lgpl.txt that was distributed with this file.
;; If it is not present, you can access it from
;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
;; version) or write to the Free Software Foundation, Inc., 59 Temple Place,
;; Suite 330, Boston, MA 02111-1307 USA
;; Description:
;; aserve's main loop
;;- This code in this file obeys the Lisp Coding Standard found in
;;- http://www.franz.com/~jkf/coding_standards.html
;;-
(in-package :net.aserve)
; stream that reads the input and chunks the data to the output
(def-stream-class chunking-stream (single-channel-simple-stream)
())
(defvar *binary-crlf*
(make-array 2 :element-type '(unsigned-byte 8)
:initial-contents '(#.(char-code #\return)
#.(char-code #\linefeed))))
(defmethod device-open ((p chunking-stream) dummy options)
(declare (ignore dummy))
(let ((output-handle (getf options :output-handle)))
(setf (slot-value p 'excl::input-handle) nil)
(setf (slot-value p 'excl::output-handle) output-handle)
(install-single-channel-character-strategy
p (stream-external-format output-handle)
nil)
(add-stream-instance-flags p :output :simple)
(setf (slot-value p 'excl::buffer)
(or (getf options :buffer)
(make-array (* 4 1024) :element-type '(unsigned-byte 8))))
(setf (slot-value p 'excl::control-out) excl::*std-control-out-table*)
t))
(defmethod print-object ((stream chunking-stream) s)
(print-unreadable-object (stream s :identity *print-escape* :type t)
(format s "ef ~s, to ~s "
(excl::ef-name (stream-external-format stream))
(slot-value stream 'excl::output-handle))))
(defmethod device-write ((p chunking-stream) buffer start end blocking)
(declare (ignore blocking))
(setf (slot-value p 'excl::oc-state) nil)
(let ((buffer (or buffer (slot-value p 'excl::buffer)))
(output (slot-value p 'excl::output-handle)))
(setq end (or end (length buffer)))
(if* (> end start)
then ; write it out with chunking
; chunk header
(format output "~x" (- end start))
(write-sequence *binary-crlf* output)
(write-sequence buffer output :start start :end end)
(write-sequence *binary-crlf* output)
(force-output output)))
end)
(defmethod device-close ((p chunking-stream) abort)
;;
;; note: we don't close the inner stream
;;
(let ((inner-stream (slot-value p 'excl::output-handle)))
(if* (not abort) then (force-output p))
; chunking eof
(write-char #\0 inner-stream)
(write-sequence *binary-crlf* inner-stream)
(write-sequence *binary-crlf* inner-stream)
(force-output inner-stream)
p))
(without-package-locks
(defmethod excl::inner-stream ((p chunking-stream))
(slot-value p 'excl::output-handle)))
;;; un chunking
;;
;; (make-instance 'unchunker-stream :input-handle stream)
;;
;; creates a unchunker-stream which filters the input-handle stream
;; filters out the meta data about chunk sizes.
;; unchunker stream returns eof when the end of the chunked data
;; is reached however the inner stream is not closed.
;;
(def-stream-class unchunking-stream (single-channel-simple-stream)
((state :initform :need-count
:accessor unchunking-state)
(count :initform 0
:accessor unchunking-count)))
(defmethod device-open ((p unchunking-stream) dummy options)
(declare (ignore dummy))
(let ((input-handle (getf options :input-handle)))
(setf (slot-value p 'excl::input-handle) input-handle)
(setf (slot-value p 'excl::output-handle) nil)
(install-single-channel-character-strategy
p (stream-external-format input-handle) nil)
(setf (stream-external-format p) (stream-external-format input-handle))
(add-stream-instance-flags p :input :simple)
(setf (slot-value p 'excl::buffer)
(or (getf options :buffer)
(make-array (* 4 1024) :element-type '(unsigned-byte 8))))
(setf (slot-value p 'excl::co-state) nil)
(setf (slot-value p 'excl::oc-state) nil)
t))
(defmethod print-object ((stream unchunking-stream) s)
(print-unreadable-object (stream s :identity *print-escape* :type t)
(format s "ef ~s, from ~s "
(excl::ef-name (stream-external-format stream))
(slot-value stream 'excl::input-handle))))
(defmethod device-read ((p unchunking-stream) buffer start end blocking)
(declare (ignore blocking))
(setq buffer (or buffer (slot-value p 'excl::buffer)))
(setq end (or end (length buffer)))
(loop
(let ((state (unchunking-state p))
(ins (slot-value p 'excl::input-handle)))
(case state
(:eof
(return-from device-read -1))
(:need-count
(let ((count 0)
(seen nil))
; read and parse
(loop
(let ((ch (read-byte ins nil nil)))
(if* (null ch)
then (error "premature eof before chunking data"))
(if* (<= #.(char-int #\0) ch #.(char-int #\9))
then (setq count (+ (ash count 4) (- ch #.(char-int #\0)))
seen t)
elseif (<= #.(char-int #\a) ch #.(char-int #\f))
then (setq count (+ (ash count 4) 10 (- ch #.(char-int #\a)))
seen t)
elseif (<= #.(char-int #\A) ch #.(char-int #\F))
then (setq count (+ (ash count 4) (+ 10 (- ch #.(char-int #\A))))
seen t)
elseif seen
then (return) ; valid count
else ; non hex char
(error "bad chunking count"))))
; now skip to newline
(loop
(let ((ch (read-byte ins nil nil)))
(if* (null ch) then (error "premature eof before chunking data"))
(if* (eq ch #.(char-int #\newline))
then (return))))
(if* (zerop count)
then ; chunking eof, read trailers and trailing crlf
(let ((seen-stuff-on-line nil))
(loop
(let ((ch (read-byte ins nil nil)))
(if* (null ch) then (error "premature eof before chunking data"))
(if* (eq ch #.(char-int #\newline))
then (if* (not seen-stuff-on-line)
then (return)
else (setq seen-stuff-on-line nil) ; reset
)
elseif (eq ch #.(char-int #\return))
then nil ;ignore
else (setq seen-stuff-on-line t)))))
; return signal of eof
(setf (unchunking-state p) :eof)
(return-from device-read -1)
else ; now ready to ready data
(setf (unchunking-state p) :read-data
(unchunking-count p) count)
)))
(:read-data
;; we'll read all we can from this chunk
(let ((count (unchunking-count p)))
(if* (zerop count)
then ; read crlf
(setf (unchunking-state p) :need-count)
else (do ((bytes-read 0)
(i start (+ i bytes-read))
(count count (- count bytes-read)))
((or (zerop count)
(>= i end))
(if* (zerop count)
then (loop (let ((ch (read-byte ins)))
(if* (eq ch #.(char-int #\newline))
then (return))))
(setf (unchunking-state p) :need-count))
(setf (unchunking-count p) count)
(return-from device-read (- i start)))
(setf bytes-read (- (read-sequence buffer ins :start i :end (min (+ i count) end))
i))))))))))
(defmethod device-close ((p unchunking-stream) abort)
(declare (ignore abort))
p)
(without-package-locks
(defmethod excl::inner-stream ((p unchunking-stream))
(slot-value p 'excl::input-handle)))
(without-package-locks
(defmethod excl::record-stream-advance-to-eof ((p unchunking-stream))
;; if the stream is composed of records ending in a pseudo eof
;; then read up to an eof
(loop
;; advance to eof
(if* (null (read-byte p nil nil)) then (return)))
p))
Jump to Line
Something went wrong with that request. Please try again.