fastcgi-cmucl/README 0100644 0003730 0001751 00000002522 07224625575 013473 0 ustar chery devel I put the following in my /etc/apache/httpd.conf:
=========================================
LoadModule fastcgi_module /usr/lib/apache/1.3/mod_fastcgi.so
# this goes after User/Group setting
FastCgiExternalServer /home/admin/chery/public_html/appserv -socket appserv.socket
SetHandler fastcgi-script
Options ExecCGI
=========================================
and this in ~chery/public_html/appserv:
=========================================
#! /bin/sh
exec /usr/bin/lisp -eval '(progn (load "/home/admin/chery/projects/fastcgi-cmucl/fastcgi") (load "/home/admin/chery/projects/fastcgi-cmucl/test") (main))' >> /tmp/appserv.dump 2>&1
=========================================
which resulted in http://localhost/~chery/appserv giving me proper
test output.
The test program can handle multipart/form-data entities as well, I
used this form:
=========================================
Appform
Appform
=========================================
Read the documentation strings.
Feedback welcome.
fastcgi-cmucl/fastcgi.lisp 0100644 0003730 0001751 00000125150 07224620113 015106 0 ustar chery devel (defpackage "FASTCGI"
(:use "COMMON-LISP" "SYSTEM")
(:export "FASTCGI-EXTERNAL-UNIX-SERVER"
"FASTCGI-DYNAMIC-SERVER"
"MAKE-FASTCGI-REQUEST"
"FASTCGI-REQUEST"
"FASTCGI-REQUEST-QUERY-STRING"
"FASTCGI-REQUEST-METHOD"
"FASTCGI-REQUEST-SCRIPT-NAME"
"FASTCGI-REQUEST-URI"
"FASTCGI-REQUEST-CONTENT-TYPE"
"FASTCGI-REQUEST-CONTENT-LENGTH"
"FASTCGI-REQUEST-PARAMS"
"FASTCGI-REQUEST-PARAMS-END"
"FASTCGI-REQUEST-STDIN-HANDLER"
"FASTCGI-REQUEST-STDIN"
"FASTCGI-REQUEST-STDOUT"
"FASTCGI-REQUEST-STDERR"
"FASTCGI-SEND-END-REQUEST"
"FASTCGI-REQUEST-OUTPUT-STREAM"
"FASTCGI-REQUEST-ERROR-STREAM"
"FASTCGI-MULTIPART-HANDLER"
"FASTCGI-MULTIPART-REQUEST"
"FASTCGI-MULTIPART-CURRENT-NAME"
"FASTCGI-MULTIPART-CONTENT-TYPE"
"FASTCGI-MULTIPART-BODY-HANDLER"
"FASTCGI-MULTIPART-HEADERS"
"MIME-HANDLE-BODY"
"MIME-HANDLE-HEADER"
"MIME-HANDLE-BODY-START"
"MIME-HANDLE-BODY-END"
"MIME-HANDLE-MULTIPART-END"
"MAKE-MIME-DECODER"
"MIME-HANDLE-DATA"
"*FASTCGI-STREAM-BUFFER-SIZE*")
(:documentation "Implementation of the FastCGI interface specification."))
(in-package :fastcgi)
;(declaim (optimize (safety 1)
; (space 3)
; (speed 3)))
(defclass fastcgi-request ()
((request-id :accessor request-id
:initform nil
:type fixnum)
(fastcgi-stream :accessor request-stream
:initform nil)
(output-stream :accessor request-output-stream
:initform nil)
(error-stream :accessor request-error-stream
:initform nil)
(query-string :accessor fastcgi-request-query-string
:initform nil
:documentation "Query string part of the request URI (after the parameters have been received)")
(request-method :accessor fastcgi-request-method
:initform nil
:documentation "Request method (\"GET\", \"POST\" etc.) of the request (after the parameters have been received)")
(script-name :accessor fastcgi-request-script-name
:initform nil
:documentation "Name of the script handling the request (after the parameters have been received)")
(request-uri :accessor fastcgi-request-uri
:initform nil
:documentation "Full request URI (after the parameters have been received)")
(content-type :accessor fastcgi-request-content-type
:initform nil
:documentation "(MIME) Content type of the input entity (after the parameters have been received)")
(content-length :accessor fastcgi-request-content-length
:initform nil
:documentation "Length of the input entity (after the parameters have been received)")
(params :accessor fastcgi-request-params
:initform nil
:type list
:documentation "Rest of the parameters as a lower case string keyed association list (after the parameters have been received)")
(stdin-handler :accessor fastcgi-request-stdin-handler))
(:documentation "Represents a single HTTP request passed from the HTTP
server. It is explicitly passed around, there is no default request,
although a new Lisp thread is created for each request. A request lives
through a number of sequence points:
1 - The request is created. (make-fastcgi-request request-factory)
2 - Parameters are being received.
3 - Parameters have been received.
4 - Input is being received. (fastcgi-request-stdin request buffer start end)
zero or more times.
5 - Input has been received. (fastcgi-request-stdin request buffer start end)
with (= start end).
6 - The request is ended. The user calls
(fastcgi-send-end-request request app-status protocol-status).
The user can output to (request-{output,error}-stream request) at any time
prior to ending the request. It is assumed that the user outputs headers
separated by CR LF pairs followed by two CR LF pairs followed by the response
body to the output stream. The error stream is possibly redirected to the
HTTP server logs. (It goes to the error log on Apache.)"))
(defmethod initialize-instance :after ((request fastcgi-request) &rest rest)
(setf (fastcgi-request-stdin-handler request) request))
(defgeneric make-fastcgi-request (request-factory)
(:documentation "Called by FastCGI when initializing a request."))
(defgeneric fastcgi-request-stdin ((request fastcgi-request)
buffer start position)
(:documentation "Called by FastCGI when data is received on stdin. The
data is the contents of buffer between indices start and position. A data
packet with zero length signals the end of stdin."))
(defmethod fastcgi-request-stdout ((request fastcgi-request) buffer)
(declare (type (simple-array * (*)) buffer))
(send-fastcgi-packet request 6 buffer))
(defmethod fastcgi-request-stderr ((request fastcgi-request) buffer)
(declare (type (simple-array * (*)) buffer))
(send-fastcgi-packet request 7 buffer))
(defun fastcgi-send-end-request (request app-status protocol-status)
"Sends a FastCGI end request packet. Transmits the application status
and the protocol status."
(declare (type fastcgi-request request)
(type fixnum app-status)
(type symbol protocol-status))
(let ((rec (make-array 8
:element-type '(unsigned-byte 8)
:initial-element 0)))
(setf (aref rec 0) (ldb (byte 8 24) app-status))
(setf (aref rec 1) (ldb (byte 8 16) app-status))
(setf (aref rec 2) (ldb (byte 8 8) app-status))
(setf (aref rec 3) (ldb (byte 8 0) app-status))
(setf (aref rec 4) (cdr (assoc protocol-status
'((:request-complete . 0)
(:cant-mpx-conn . 1)
(:overloaded . 2)
(:unknown-role . 3)))))
(send-fastcgi-packet request 3 rec)))
(defun fastcgi-external-unix-server (socket-pathname request-factory)
"Makes a FastCGI server with a UNIX domain socket interface that calls
(make-fastcgi-request request-factory) which must return a subclass of
fastcgi-request for each request received. Creates a new process for each
connection requested."
(listen-socket (create-unix-listener socket-pathname) request-factory))
(defun fastcgi-dynamic-server (request-factory)
"Makes a FastCGI server with an interface selected and created by the
web server. The FastCGI server calls (make-fastcgi-request request-factory)
which must return a subclass of fastcgi-request for each request received.
Creates a new process for each connection requested."
(listen-socket 0 request-factory))
;;;; Public interface ends here.
(defun listen-socket (listen-fd request-factory)
(loop for comm-fd = (progn
(mp:process-wait-until-fd-usable listen-fd :input)
(unix:unix-accept listen-fd nil 0))
do (mp:make-process (lambda ()
(handle-fastcgi-stream comm-fd
request-factory)))))
(defparameter *fastcgi-version* 1
"Version number of the protocol used.")
(defun create-unix-listener (path &optional (kind :stream))
(when (probe-file path)
(delete-file path))
(let ((socket (extensions:create-unix-socket kind)))
(alien:with-alien ((sockaddr extensions::unix-sockaddr))
(setf (alien:slot sockaddr 'extensions::family) extensions::af-unix)
(kernel:copy-to-system-area path
(* vm:vector-data-offset vm:word-bits)
(alien:alien-sap
(alien:slot sockaddr 'extensions::path))
0
(* (1+ (length path)) vm:byte-bits))
(when (minusp (unix:unix-bind
socket (alien:alien-sap sockaddr)
(alien:alien-size extensions::unix-sockaddr :bytes)))
(let ((errmsg (unix:get-unix-error-msg unix:unix-errno)))
(unix:unix-close socket)
(error "Error binding socket to name [~A]: ~A" path errmsg))))
(when (eq kind :stream)
(when (minusp (unix:unix-listen socket 5))
(let ((errmsg (unix:get-unix-error-msg)))
(unix:unix-close socket)
(error "Error listening to socket: ~A" errmsg))))
(unix:unix-chmod path #o777)
socket))
(defclass fastcgi-stream ()
((fd :accessor fastcgi-stream-fd
:initarg :fd
:type fixnum)
(request-factory :accessor fastcgi-stream-request-factory
:initarg :request-factory)
(request-hash :accessor fastcgi-stream-request-hash
:initarg :request-hash
:initform (make-hash-table)
:type hashtable)))
;;;; The format of a fastcgi packet is:
;;;; header, 8 bytes: [ignored request-type request-id-high request-id-low
;;;; content-length-high content-length-low padding-length ignored]
;;;; content, (+ (* 256 content-length-high) content-length-low) bytes
;;;; padding, padding-length bytes
(defparameter *buffer-size* 65536
"Size of the FastCGI stream input buffer.")
(defun handle-fastcgi-stream (comm-fd request-factory)
"Handles a bidirectional stream of FastCGI packets over a file descriptor."
(let ((fastcgi-stream (make-instance 'fastcgi-stream
:fd comm-fd
:request-factory request-factory))
(buffer (make-array *buffer-size*
:element-type '(unsigned-byte 8)
:initial-element 0))
(end *buffer-size*))
(labels ((receive (start position packet)
(mp:process-wait-until-fd-usable comm-fd :input)
(let ((length (unix:unix-recv
comm-fd
(alien:sap-alien
(sap+ (vector-sap buffer) position)
(* char))
(- end position)
0)))
(when (plusp length)
(test-for-packet start (+ position length) packet))))
(test-for-packet (start position packet)
(let ((packet (or packet
(and (>= (- position start) 8)
(make-packet fastcgi-stream
buffer start position)))))
(cond
((and packet (>= (- position start) (packet-length packet)))
(handle-fastcgi-packet-block packet buffer start
position)
(test-for-packet (+ start (packet-length packet))
position nil))
((= position end)
(cond
(packet
(handle-fastcgi-packet-block packet buffer start end)
(receive 0 0 packet))
(t
(setf (subseq buffer 0) (subseq buffer start))
(receive 0 (- position start) nil))))
(t
(receive start position packet))))))
(receive 0 0 nil))
(unix:unix-close comm-fd)))
(defclass fastcgi-packet ()
((fastcgi-stream :accessor packet-stream
:initarg :fastcgi-stream)
(request-id :accessor packet-request-id
:initarg :request-id
:type fixnum)
(content-length :accessor packet-content-length
:initarg :content-length
:type fixnum)
(packet-length :accessor packet-length
:initarg :packet-length
:type fixnum)
(packet-handled :accessor packet-handled
:initform 0
:type fixnum)))
(defmethod handle-fastcgi-packet-block ((packet fastcgi-packet)
buffer start position)
(declare (type (simple-array (unsigned-byte 8) (*)) buffer)
(type fixnum start position))
(let* ((length (- position start))
(content-length (+ (packet-content-length packet) 8))
(handled (packet-handled packet))
(real-start (if (zerop handled) (+ start 8) start)))
(cond
((<= length (- content-length handled))
(handle-fastcgi-packet-fragment packet buffer real-start position))
((> content-length handled)
(handle-fastcgi-packet-fragment packet buffer real-start
(+ start (- content-length handled)))))
(incf (packet-handled packet) length)))
(defmethod packet-request ((packet fastcgi-packet))
(gethash (packet-request-id packet)
(fastcgi-stream-request-hash (packet-stream packet))))
(defclass begin-request-packet (fastcgi-packet)
())
(defclass abort-request-packet (fastcgi-packet)
())
(defclass params-packet (fastcgi-packet)
((data :accessor packet-data
:initform (make-array 0 :element-type '(unsigned-byte 8)))
(state :accessor packet-state
:initform :start)
(name :accessor packet-name
:initform nil)
(value :accessor packet-value
:initform nil)))
(defclass stdin-packet (fastcgi-packet)
())
(defclass data-packet (fastcgi-packet)
())
(defclass get-values-packet (fastcgi-packet)
())
(defun make-packet (fastcgi-stream buffer start position)
"Create a packet object from the packet header bytes."
(declare (type fastcgi-stream fastcgi-stream)
(type (simple-array (unsigned-byte 8) (*)) buffer)
(type fixnum start position))
(let* ((request-type (aref buffer (+ start 1)))
(packet-class (and (< request-type 10)
(aref #(nil
begin-request-packet
abort-request-packet
nil
params-packet
stdin-packet
nil
nil
data-packet
get-values-packet) request-type)))
(content-length (logior (ash (aref buffer (+ start 4)) 8)
(aref buffer (+ start 5))))
(padding-length (aref buffer (+ start 6))))
(when packet-class
(make-instance packet-class
:fastcgi-stream fastcgi-stream
:request-id (logior (ash (aref buffer (+ start 2)) 8)
(aref buffer (+ start 3)))
:content-length content-length
:packet-length (+ content-length padding-length 8)))))
(defmethod handle-fastcgi-packet-fragment ((packet begin-request-packet)
buffer start position)
(declare (type (simple-array (unsigned-byte 8) (*)) buffer)
(type fixnum start position))
(let* ((fastcgi-stream (packet-stream packet))
(request-id (packet-request-id packet))
(request (make-fastcgi-request
(fastcgi-stream-request-factory fastcgi-stream))))
(setf (request-stream request) fastcgi-stream)
(setf (request-id request) request-id)
(setf (gethash request-id (fastcgi-stream-request-hash fastcgi-stream))
request)))
(defmethod handle-fastcgi-packet-fragment ((packet abort-request-packet)
buffer start position)
(declare (type (simple-array (unsigned-byte 8) (*)) buffer)
(type fixnum start position))
(fastcgi-send-end-request (packet-request packet) 0 :request-complete)
(remhash (packet-request-id packet)
(fastcgi-stream-request-hash (packet-stream packet))))
(defmethod handle-fastcgi-packet-fragment ((packet params-packet)
buffer start position)
(declare (type (simple-array (unsigned-byte 8) (*)) buffer)
(type fixnum start position))
(let* ((length (- position start))
(data (packet-data packet))
(data-length (length data))
(pos (- data-length))
(request (packet-request packet)))
(declare (type (simple-array (unsigned-byte 8) (*)) data))
(if (zerop length)
(fastcgi-request-params-end request)
(labels ((get-name (pos name-len value-len)
(declare (type fixnum pos name-len value-len))
(if (<= (+ pos name-len) length)
(get-value (+ pos name-len) (copy-array pos name-len)
value-len)
(progn
(setf (packet-name packet) name-len)
(setf (packet-value packet) value-len)
(bail-out pos :get-name))))
(get-value (pos name value-len)
(declare (type fixnum pos value-len)
(type (simple-array (unsigned-byte 8) (*)) name))
(if (<= (+ pos value-len) length)
(progn
(fastcgi-request-param request name
(copy-array pos value-len))
(start (+ pos value-len)))
(progn
(setf (packet-name packet) name)
(setf (packet-value packet) value-len)
(bail-out pos :get-value))))
(start (pos)
(declare (type fixnum pos))
(if (or (< (+ pos 8) length)
(zerop length))
(multiple-value-bind (head p)
(if (minusp pos)
(values (copy-array pos 8) 0)
(values buffer (+ start pos)))
(multiple-value-bind (name-len offset)
(decode-length head p)
(multiple-value-bind (value-len offset2)
(decode-length head (+ p offset))
(get-name (+ pos offset offset2)
name-len value-len))))
(bail-out pos :start)))
(decode-length (buf p)
(declare (type (simple-array (unsigned-byte 8) (*)) buf)
(type fixnum p))
(if (zerop (ldb (byte 1 7) (aref buf p)))
(values (aref buf p) 1)
(values (logior (ash (ldb (byte 7 0) (aref buf p)) 24)
(ash (aref buf (1+ p)) 16)
(ash (aref buf (+ p 2)) 8)
(aref buf (+ p 3)))
4)))
(bail-out (pos state)
(declare (type fixnum pos)
(type symbol state))
(setf (packet-state packet) state)
(when (< pos length)
(setf (packet-data packet)
(if (minusp pos)
(concatenate '(array (unsigned-byte 8))
(subseq data (+ data-length pos))
(subseq buffer start position))
(subseq buffer (+ start pos) position)))))
(copy-array (pos len)
(declare (type fixnum pos len))
(if (minusp pos)
(concatenate '(array (unsigned-byte 8))
(subseq data (+ data-length pos))
(subseq buffer start (+ start len pos)))
(subseq buffer (+ start pos) (+ start pos len)))))
(case (packet-state packet)
(:start (start pos))
(:get-name (get-name pos (packet-name packet) (packet-value packet)))
(:get-value (get-value pos (packet-name packet)
(packet-value packet))))))))
(defmacro param-handler ((key &key default) &rest rest)
(let ((hashtable (make-hash-table :test #'equal))
(key-string-gensym (gensym "KEY-STRING"))
(i-gensym (gensym "I")))
(loop for (match . body) in rest
for i from 0
do (setf (gethash match hashtable) i))
`(let* ((,key-string-gensym (map 'string #'code-char ,key))
(,i-gensym (gethash ,key-string-gensym ,hashtable)))
(if ,i-gensym
(funcall (aref (vector ,@(loop for (match . body) in rest
collect `(lambda ()
,@body)))
,i-gensym))
(when ,default
(funcall ,default ,key-string-gensym))))))
(defmethod fastcgi-request-param ((request fastcgi-request) name value)
(param-handler (name :default (lambda (key-string)
(push (cons key-string value)
(fastcgi-request-params request))))
("QUERY_STRING" (setf (fastcgi-request-query-string request)
(parse-query (map 'string #'code-char value) 0)))
("REQUEST_METHOD" (setf (fastcgi-request-method request) value))
("SCRIPT_NAME" (setf (fastcgi-request-script-name request) value))
("REQUEST_URI" (setf (fastcgi-request-uri request)
(parse-uri (map 'string #'code-char value))))
("CONTENT_TYPE" (setf (fastcgi-request-content-type request)
(parse-content-type (map 'string #'code-char
value))))
("CONTENT_LENGTH" (setf (fastcgi-request-content-length request) value))))
(defmethod handle-fastcgi-packet-fragment ((packet stdin-packet)
buffer start position)
(fastcgi-request-stdin
(fastcgi-request-stdin-handler (packet-request packet))
buffer start position))
(defmethod handle-fastcgi-packet-fragment ((packet data-packet)
buffer start position))
(defmethod handle-fastcgi-packet-fragment ((packet get-values-packet)
buffer start position))
(defun send-fastcgi-packet (request packet-type data
&optional (start 0) (end (length data)))
"Send a packet with given type and data in context of a request."
(declare (type fastcgi-request request)
(type fixnum packet-type)
(type (simple-array * (*)) data))
(let* ((record-head (make-array 8
:element-type '(unsigned-byte 8)
:initial-element 0))
(data-len (- end start))
(padding-len (nth-value 1 (floor (- 8 data-len) 8)))
(request-id (request-id request))
(fd (fastcgi-stream-fd (request-stream request))))
(declare (type fixnum request-id fd))
(setf (aref record-head 0) *fastcgi-version*)
(setf (aref record-head 1) packet-type)
(setf (aref record-head 2) (ldb (byte 8 8) request-id))
(setf (aref record-head 3) (ldb (byte 8 0) request-id))
(setf (aref record-head 4) (ldb (byte 8 8) data-len))
(setf (aref record-head 5) (ldb (byte 8 0) data-len))
(setf (aref record-head 6) padding-len)
(flet ((fd-send (buffer start end)
(loop for position fixnum = start then (+ position length)
for length fixnum
= (progn
(mp:process-wait-until-fd-usable fd :output)
(unix:unix-send fd
(alien:sap-alien
(sap+ (vector-sap buffer)
position)
(* char))
(- end position)
0))
if (zerop length)
do (error "Write truncated.")
while (< (+ position length) end))))
(fd-send record-head 0 8)
(when (plusp data-len)
(fd-send data start end)
(when (plusp padding-len)
(fd-send (make-array padding-len
:element-type '(unsigned-byte 8)
:initial-element 0)
0 padding-len))))))
(defun parse-uri (string)
(labels ((segment (position chars alist)
(let ((char (and (< position (length string))
(aref string position))))
(case char
((nil)
(list (reverse (acons (coerce (reverse chars) 'string)
nil alist))))
(#\?
(cons (reverse (acons (coerce (reverse chars) 'string)
nil alist))
(parse-query string (1+ position))))
(#\/
(segment (1+ position) nil
(acons (coerce (reverse chars) 'string) nil alist)))
(#\;
(parameter (1+ position) nil nil
(coerce (reverse chars) 'string) alist))
(#\%
(segment (+ 3 position)
(cons (code-char (parse-integer string
:start (1+ position)
:end (+ 3 position)
:radix 16))
chars)
alist))
(t
(segment (1+ position) (cons char chars) alist)))))
(parameter (position chars params segment alist)
(let ((char (and (< position (length string))
(aref string position))))
(case char
((nil)
(list (reverse (acons segment
(cons (coerce (reverse chars) 'string)
params)
alist))))
(#\?
(cons (reverse (acons segment
(cons (coerce (reverse chars) 'string)
params)
alist))
(parse-query string (1+ position))))
(#\/
(segment (1+ position) nil
(acons segment
(cons (coerce (reverse chars) 'string)
params)
alist)))
(#\;
(parameter (1+ position) nil
(cons (coerce (reverse chars) 'string) params)
segment alist))
(#\%
(parameter (+ 3 position)
(cons (code-char
(parse-integer string
:start (1+ position)
:end (+ 3 position)
:radix 16))
chars)
params segment alist))
(t
(parameter (1+ position) (cons char chars)
params segment alist))))))
(segment 1 nil nil)))
(defun parse-query (string position)
(labels ((key (position chars alist)
(let ((char (and (< position (length string))
(aref string position))))
(case char
((nil)
(acons (coerce (reverse chars) 'string) nil alist))
(#\=
(value (1+ position) nil
(coerce (reverse chars) 'string) alist))
(#\%
(key (+ 3 position)
(cons (code-char (parse-integer string
:start (1+ position)
:end (+ 3 position)
:radix 16))
chars)
alist))
(t
(key (1+ position) (cons char chars) alist)))))
(value (position chars key alist)
(let ((char (and (< position (length string))
(aref string position))))
(case char
((nil)
(acons key (coerce (reverse chars) 'string) alist))
((#\& #\;)
(key (1+ position)
nil
(acons key (coerce (reverse chars) 'string) alist)))
(#\%
(value (+ 3 position)
(cons (code-char (parse-integer string
:start (1+ position)
:end (+ 3 position)
:radix 16))
chars)
key
alist))
(t
(value (1+ position) (cons char chars) key alist))))))
(key position nil nil)))
(defun parse-content-type (string)
(let* ((source (make-instance 'rfc822-token-source
:string string
:specials '(#\( #\) #\< #\> #\@ #\, #\; #\:
#\\ #\[ #\] #\/ #\? #\=)))
(type (string-downcase (cdr (rts-next source))))
(slash (rts-next source))
(subtype (string-downcase (cdr (rts-next source))))
(params (loop while (eql (car (rts-next source)) :special)
collect (let ((attribute (rts-next source))
(equals (rts-next source))
(value (rts-next source)))
(cons (string-downcase (cdr attribute))
(cdr value))))))
(acons type subtype params)))
(defun parse-generic (string)
(let* ((source (make-instance 'rfc822-token-source
:string string
:specials '(#\( #\) #\< #\> #\@ #\, #\; #\:
#\\ #\[ #\] #\/ #\? #\=)))
(value (string-downcase (cdr (rts-next source))))
(params (loop while (eql (car (rts-next source)) :special)
collect (let ((attribute (rts-next source))
(equals (rts-next source))
(value (rts-next source)))
(cons (string-downcase (cdr attribute))
(cdr value))))))
(cons value params)))
(defun parse-string (string)
(let ((source (make-instance 'rfc822-token-source
:string string)))
(cdr (rts-next source))))
(defclass rfc822-token-source ()
((string :accessor rts-string
:initarg :string)
(position :accessor rts-position
:initform 0)
(specials :accessor rts-specials
:initarg :specials
:initform '(#\( #\) #\< #\> #\@ #\, #\; #\: #\\ #\. #\[ #\]))))
(defmethod rts-next ((source rfc822-token-source))
(let* ((string (rts-string source))
(length (length string))
(specials (rts-specials source)))
(labels ((return-eos ()
(setf (rts-position source) length)
(list :eos))
(atom (start pos)
(let ((char (and (< pos length) (aref string pos))))
(if (or (not char)
(<= (char-code char) 32)
(member char specials))
(progn
(setf (rts-position source) pos)
(cons :atom (subseq string start pos)))
(atom start (1+ pos)))))
(quoted-string (pos chars)
(let ((char (and (< pos length) (aref string pos))))
(case char
((nil) (return-eos))
(#\" (setf (rts-position source) (1+ pos))
(cons :quoted-string (coerce (reverse chars) 'string)))
(#\\ (if (< (1+ pos) length)
(quoted-string (+ pos 2)
(cons (aref string (1+ pos)) chars))
(return-eos)))
(t (quoted-string (1+ pos) (cons char chars))))))
(domain-literal (pos chars)
(let ((char (and (< pos length) (aref string pos))))
(case char
((nil) (return-eos))
(#\] (setf (rts-position source) (1+ pos))
(cons :domain-literal
(coerce (reverse chars) 'string)))
(#\\ (if (< (1+ pos) length)
(domain-literal (+ pos 2)
(cons (aref string (1+ pos))
chars))
(return-eos)))
(t (domain-literal (1+ pos) (cons char chars))))))
(comment (pos level)
(case (and (< pos length) (aref string pos))
((nil) (return-eos))
(#\( (comment (1+ pos) (1+ level)))
(#\) (setf (rts-position source) (1+ pos))
(if (zerop level)
(list :comment)
(comment (1+ pos) (1- level))))
(#\\ (comment (+ pos 2) level))
(t (comment (1+ pos) level))))
(init (pos)
(let ((char (and (< pos length) (aref string pos))))
(case char
((nil) (return-eos))
((#\Space #\Tab) (init (1+ pos)))
(#\( (if (eql (car (comment (1+ pos) 0)) :comment)
(init (rts-position source))
(return-eos)))
(#\" (quoted-string (1+ pos) nil))
(#\[ (domain-literal (1+ pos) nil))
(t (if (member char specials)
(progn
(setf (rts-position source) (1+ pos))
(cons :special char))
(atom pos (1+ pos))))))))
(init (rts-position source)))))
(defclass mime-decoder ()
((receiver :accessor decoder-receiver
:initarg :receiver)
(buf-pos :accessor decoder-buf-pos
:initform 0)))
(defclass mime-quoted-printable-decoder (mime-decoder)
())
(defclass mime-base64-decoder (mime-decoder)
((num :accessor decoder-num
:initform 0
:type fixnum)))
(defun make-mime-decoder (encoding-type receiver)
(cond
((string= encoding-type "quoted-printable")
(make-instance 'mime-quoted-printable-decoder :receiver receiver))
((string= encoding-type "base64")
(make-instance 'mime-base64-decoder :receiver receiver))
(t
receiver)))
(defparameter *mime-reverse-hextable*
#(nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
0 1 2 3 4 5 6 7 8 9 nil nil nil nil nil nil
nil 10 11 12 13 14 15 nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil 10 11 12 13 14 15 nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil
nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil nil))
(defmethod mime-handle-data ((decoder mime-quoted-printable-decoder)
data start end)
(let ((buf (make-array (- end start) :element-type '(unsigned-byte 8))))
(labels ((base (pos buf-pos)
(if (< pos end)
(let ((octet (aref data pos)))
(if (= octet 61)
(equals (1+ pos) buf-pos)
(progn
(setf (aref buf buf-pos) (aref data pos))
(base (1+ pos) (1+ buf-pos)))))
(bail-out buf-pos :base)))
(equals (pos buf-pos)
(if (< pos end)
(let ((n (aref *mime-reverse-hextable* (aref data pos))))
(if n
(equals-1 (1+ pos) buf-pos n)
(skip-eol pos buf-pos)))
(bail-out buf-pos :equals)))
(equals-1 (pos buf-pos n)
(if (< pos end)
(progn
(setf (aref buf buf-pos)
(+ (* 16 n) (aref *mime-reverse-hextable*
(aref data pos)))))
(bail-out buf-pos n)))
(skip-eol (pos buf-pos)
(if (< pos end)
(if (= (aref data pos) 10)
(base (1+ pos) buf-pos)
(skip-eol (1+ pos) buf-pos))
(bail-out buf-pos :skip-eol)))
(bail-out (buf-pos state)
(mime-handle-data (decoder-receiver decoder) buf 0 buf-pos)
(setf (decoder-state decoder) state)))
(case (decoder-state decoder)
(:base (base start 0))
(:equals (equals start 0))
(:skip-eol (skip-eol start 0))
(t (equals-1 start 0 (decoder-state decoder)))))))
(defparameter *mime-base64-table*
#(65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80
81 82 83 84 85 86 87 88 89 90 97 98 99 100 101 102
103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118
119 120 121 122 48 49 50 51 52 53 54 55 56 57 43 47))
(defparameter *mime-reverse-base64-table*
(let ((v (make-array 256 :initial-element nil)))
(loop for octet across *mime-base64-table*
for index from 0 below 63
do (setf (aref v octet) index))
v))
(defmethod mime-handle-data ((decoder mime-base64-decoder)
data start end)
(let ((buf (make-array (- end start) :element-type '(unsigned-byte 8))))
(labels ((base (pos buf-pos)
(if (< pos end)
(let ((n (aref *mime-reverse-base64-table*
(aref data pos))))
(if n
(base-1 (1+ pos) buf-pos n)
(skip (1+ pos) buf-pos)))
(bail-out buf-pos :base nil)))
(base-1 (pos buf-pos n)
(if (< pos end)
(base-2 (1+ pos) buf-pos
(+ (* 64 n) (aref *mime-reverse-base64-table*
(aref data pos))))
(bail-out buf-pos :base-1 n)))
(base-2 (pos buf-pos n)
(if (< pos end)
(base-3 (1+ pos) buf-pos
(+ (* 64 n) (aref *mime-reverse-base64-table*
(aref data pos))))
(bail-out buf-pos :base-2 n)))
(base-3 (pos buf-pos n)
(if (< pos end)
(let ((n (+ (* 64 n) (aref *mime-reverse-base64-table*
(aref data pos)))))
(setf (aref buf buf-pos) (ldb (byte 8 16) n))
(setf (aref buf (1+ buf-pos)) (ldb (byte 8 8) n))
(setf (aref buf (+ buf-pos 2)) (ldb (byte 8 0) n))
(base (1+ pos) (+ buf-pos 3)))
(bail-out buf-pos :base-3 n)))
(bail-out (buf-pos state n)
(mime-handle-data (decoder-receiver decoder) buf 0 buf-pos)
(setf (decoder-state decoder) state)
(setf (decoder-num decoder) n)))
(case (decoder-state decoder)
(:base (base start 0))
(:base-1 (base-1 start 0 (decoder-num decoder)))
(:base-2 (base-2 start 0 (decoder-num decoder)))
(:base-3 (base-3 start 0 (decoder-num decoder)))))))
(defclass fastcgi-multipart-handler ()
((request :accessor fastcgi-multipart-request
:initarg :request)
(current-name :accessor fastcgi-multipart-current-name
:initform nil
:type (or nil string))
(content-type :accessor fastcgi-multipart-content-type
:initform nil
:type (or nil string))
(body-handler :accessor fastcgi-multipart-body-handler
:initform nil)
(headers :accessor fastcgi-multipart-headers
:initform nil)
(state :accessor multipart-state
:initform (list 'front-bol))
(boundary :accessor multipart-boundary)))
(defmethod initialize-instance :after ((handler fastcgi-multipart-handler)
&rest rest)
(setf (multipart-boundary handler)
(concatenate 'string "--"
(cdr (assoc "boundary"
(fastcgi-request-content-type
(fastcgi-multipart-request handler))
:test #'string=)))))
(defmacro block-action (name args &body body)
`(,name (pos ,@args)
(if (< pos end)
(progn ,@body)
(bail-out (cons ',name (list ,@args))))))
(defmacro action-case (state other cases)
`(labels (,@(mapcar (lambda (case)
(destructuring-bind (name args &body body)
case
`(,name (pos ,@args)
(cond
((< pos end)
,@body)
(t
(bail-out (cons ',name (list ,@args))))))))
cases)
,@other)
(let ((state ,state))
(case (car state)
,@(mapcar (lambda (case)
(destructuring-bind (name args &body body)
case
`(',name (apply #',name start (cdr state)))))
cases)))))
(defmethod fastcgi-request-stdin ((handler fastcgi-multipart-handler)
buffer start end)
(let ((boundary (multipart-boundary handler)))
(action-case (multipart-state handler)
((bail-out (state)
(setf (multipart-state handler) state))
(back (pos)
(bail-out (list 'back)))
(body-bol (pos body-start candidate)
(cond
((>= pos end)
(handle-body-bail-out 'body-bol body-start candidate nil))
((= (aref buffer pos) (char-code (aref boundary 0)))
(body-match (1+ pos) body-start candidate 1))
(t
(body (1+ pos) body-start))))
(body-bol-maybe (pos body-start candidate)
(cond
((>= pos end)
(handle-body-bail-out 'body-bol-maybe body-start candidate nil))
((= (aref buffer pos) 10)
(body-bol (1+ pos) body-start candidate))
(t
(body (1+ pos) body-start))))
(body (pos body-start)
(cond
((>= pos end)
(mime-handle-body handler buffer body-start pos)
(bail-out (list 'body nil)))
((= (aref buffer pos) 10)
(body-bol (1+ pos) body-start pos))
((= (aref buffer pos) 13)
(body-bol-maybe (1+ pos) body-start pos))
(t
(body (1+ pos) body-start))))
(handle-body-bail-out (state body-start candidate boundary-pos)
(when (numberp candidate)
(mime-handle-body handler buffer body-start candidate))
(bail-out (cons state
(cons nil ; body-start undefined on next block
(cons (if (numberp candidate)
(subseq buffer candidate end)
(concatenate '(vector (unsigned-byte 8))
candidate
(subseq buffer start end)))
(and boundary-pos
(list boundary-pos)))))))
(body-match (pos body-start candidate boundary-pos)
(cond
((>= pos end)
(handle-body-bail-out 'body-match body-start candidate
boundary-pos)
(bail-out (list 'body-match nil (subseq buffer candidate end)
boundary-pos)))
((= boundary-pos (length boundary))
(mime-handle-body handler buffer body-start candidate)
(mime-handle-body-end handler)
(header-front pos))
((= (aref buffer pos) (char-code (aref boundary boundary-pos)))
(body-match (1+ pos) body-start candidate (1+ boundary-pos)))
(t
(body pos body-start)))))
((front-bol ()
(if (= (aref buffer pos) (char-code (aref boundary 0)))
(front-match (1+ pos) 1)
(front (1+ pos))))
(front ()
(if (= (aref buffer pos) 10)
(front-bol (1+ pos))
(front (1+ pos))))
(front-match (boundary-pos)
(if (= boundary-pos (length boundary))
(header-front pos)
(if (= (aref buffer pos) (char-code (aref boundary boundary-pos)))
(front-match (1+ pos) (1+ boundary-pos))
(front pos))))
(header-front ()
(if (= (aref buffer pos) 45)
(header-front-1 (1+ pos))
(header-front-2 pos)))
(header-front-1 ()
(cond
((= (aref buffer pos) 45)
(mime-handle-multipart-end handler)
(back (1+ pos)))
(t
(header-front-2 pos))))
(header-front-2 ()
(if (= (aref buffer pos) 10)
(header (1+ pos) nil)
(header-front-2 (1+ pos))))
(header (chars)
(let ((char (aref buffer pos)))
(if (= char 58)
(header-value (1+ pos)
(map 'string #'code-char (reverse chars)) nil)
(header (1+ pos) (cons char chars)))))
(header-value (key chars)
(let ((char (aref buffer pos)))
(if (= char 10)
(header-cont-maybe (1+ pos) key chars)
(header-value (1+ pos) key (cons char chars)))))
(header-cont-maybe (key chars)
(let ((char (aref buffer pos)))
(cond
((or (= char 20) (= char 9))
(header-value (1+ pos) key chars))
(t
(mime-handle-header handler key
(map 'string #'code-char (reverse chars)))
(cond
((or (= char 10) (= char 13))
(mime-handle-body-start handler)
(if (= char 10)
(body-bol (1+ pos) (1+ pos) (1+ pos))
(header-border (1+ pos))))
(t
(header (1+ pos) (list char))))))))
(header-border ()
(body-bol (1+ pos) (1+ pos) (1+ pos)))))))
(defmethod mime-handle-header ((handler fastcgi-multipart-handler) key value)
(let ((low-key (string-downcase key)))
(cond
((string= low-key "content-disposition")
(setf (fastcgi-multipart-current-name handler)
(cdr (assoc "name" (cdr (parse-generic value))
:test #'string=))))
((string= low-key "content-type")
(setf (fastcgi-multipart-content-type handler)
(parse-content-type value)))
((string= low-key "content-transfer-encoding")
(setf (fastcgi-multipart-body-handler handler)
(make-mime-decoder (parse-string value) handler)))
(t
(push (cons key value)
(fastcgi-multipart-headers handler))))))
(defmethod mime-handle-body-start ((handler fastcgi-multipart-handler))
(when (not (fastcgi-multipart-body-handler handler))
(setf (fastcgi-multipart-body-handler handler) handler)))
(defmethod mime-handle-body ((handler fastcgi-multipart-handler)
buffer start end)
(let ((receiver (fastcgi-multipart-body-handler handler)))
(when receiver
(mime-handle-data receiver buffer start end))))
(defmethod mime-handle-body-end ((handler fastcgi-multipart-handler))
nil)
(defmethod mime-handle-multipart-end ((handler fastcgi-multipart-handler))
nil)
;;;; CMUCL-specific part
(defparameter *fastcgi-stream-buffer-size* 4096
"The size of the output stream buffers in characters.")
(defmethod fastcgi-request-output-stream ((request fastcgi-request))
(or (request-output-stream request)
(setf (request-output-stream request)
(make-fastcgi-output-stream request 6))))
(defmethod fastcgi-request-error-stream ((request fastcgi-request))
(or (request-error-stream request)
(setf (request-error-stream request)
(make-fastcgi-output-stream request 7))))
(defstruct (fastcgi-output-stream (:include lisp-stream
(out #'fastcgi-stream-out)
(bout #'fastcgi-stream-bout)
(sout #'fastcgi-stream-sout)
(misc #'fastcgi-stream-misc))
(:constructor make-fastcgi-output-stream
(request channel)))
(buffer (make-string *fastcgi-stream-buffer-size*) :type string)
(buffer-position 0 :type fixnum)
(request nil :type fastcgi-request :read-only t)
(channel 6 :type fixnum :read-only t))
(defun fastcgi-stream-out (stream char)
(let ((buffer (fastcgi-output-stream-buffer stream))
(buffer-position (fastcgi-output-stream-buffer-position stream)))
(setf (aref buffer buffer-position) char)
(if (< (1+ buffer-position) (length buffer))
(setf (fastcgi-output-stream-buffer-position stream)
(1+ buffer-position))
(fastcgi-stream-flush stream))))
(defun fastcgi-stream-bout (stream byte)
(let ((buffer (fastcgi-output-stream-buffer stream))
(buffer-position (fastcgi-output-stream-buffer-position stream)))
(setf (aref buffer buffer-position) (code-char byte))
(if (< (1+ buffer-position) (length buffer))
(setf (fastcgi-output-stream-buffer-position stream)
(1+ buffer-position))
(fastcgi-stream-flush stream))))
(defun fastcgi-stream-sout (stream string start end)
(let ((length (- end start))
(buffer (fastcgi-output-stream-buffer stream)))
(cond
((>= length (length buffer))
(fastcgi-stream-flush stream)
(send-fastcgi-packet (fastcgi-output-stream-request stream)
(fastcgi-output-stream-channel stream)
string start end))
(t
(let* ((buffer-position (fastcgi-output-stream-buffer-position stream))
(buffer-remaining (- (length buffer) buffer-position))
(copy-length (min length buffer-remaining)))
(setf (subseq buffer buffer-position)
(subseq string start (+ start copy-length)))
(setf (fastcgi-output-stream-buffer-position stream)
(+ buffer-position copy-length))
(when (= copy-length buffer-remaining)
(fastcgi-stream-flush stream)
(setf (subseq buffer 0) (subseq string (+ start copy-length) end))
(setf (fastcgi-output-stream-buffer-position stream)
(- length copy-length))))))))
(defun fastcgi-stream-misc (stream operation &optional arg1 arg2)
(case operation ; :line-length :charpos :interactive-p
(:close
(fastcgi-stream-flush stream)
(send-fastcgi-packet (fastcgi-output-stream-request stream)
(fastcgi-output-stream-channel stream)
"" 0 0)
(common-lisp::set-closed-flame stream)) ; evil
((:finish-output :force-output)
(fastcgi-stream-flush stream))
(:clear-output
(setf (fastcgi-output-stream-buffer-position stream) 0))
(:element-type 'base-char)))
(defun fastcgi-stream-flush (stream)
(send-fastcgi-packet (fastcgi-output-stream-request stream)
(fastcgi-output-stream-channel stream)
(fastcgi-output-stream-buffer stream)
0
(fastcgi-output-stream-buffer-position stream))
(setf (fastcgi-output-stream-buffer-position stream) 0))
fastcgi-cmucl/multipart.fig 0100644 0003730 0001751 00000014000 07224624571 015310 0 ustar chery devel #FIG 3.2
Landscape
Center
Metric
A4
100.00
Single
-2
1200 2
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 7574.464 2573.357 8730 2520 8550 3195 8010 3645
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 9336.049 1675.887 8730 2250 8505 1755 8640 1215
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 9562.500 2036.250 9180 1035 9945 1035 10530 1575
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 9979.729 919.076 10260 1800 9585 1755 9090 1170
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 8775.000 765.000 8640 945 8775 540 8955 900
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 9998.083 1661.286 10710 1890 10395 2295 9810 2385
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 9328.807 2735.795 9630 2520 9360 3105 9000 2565
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 8135.933 4658.843 8100 3735 8685 3915 8955 4230
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 9797.885 5225.192 10080 4500 10305 4635 10485 4860
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 7807.500 4342.500 8640 4590 8505 4860 8325 5040
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 5891.371 4510.887 7515 3960 7605 4455 7560 4905
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 5147.609 3745.761 6660 5175 6210 5535 5670 5760
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 7537.500 5475.000 7875 5310 7560 5850 7200 5310
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 4136.786 5679.643 4905 5895 4770 6165 4500 6390
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 4447.500 5837.045 3555 6255 3465 5760 3645 5265
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 3476.953 5710.781 4275 5310 4365 5805 4185 6255
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 4820.625 5490.000 5040 5130 5220 5355 5220 5625
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 3757.500 6790.500 4050 6660 3780 7110 3465 6660
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 5667.188 3645.000 3870 4905 3510 4050 3510 3240
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 3054.375 4381.875 3060 5040 2655 4905 2430 4590
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 3779.790 4215.491 2520 4275 2655 3645 3105 3150
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 4843.125 2160.000 3510 2925 3330 2430 3330 1890
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 5224.257 3724.662 4050 3015 4365 2655 4770 2430
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 5145.541 4068.789 6075 2475 6660 3015 6930 3600
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 4978.707 539.224 4860 2340 4185 2160 3645 1755
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 3367.174 1494.783 3195 1575 3375 1305 3510 1620
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 2796.983 1946.638 3195 1890 3105 2205 2880 2340
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 3019.939 2256.037 2565 2205 2745 1890 3060 1800
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 2741.029 2971.323 2790 2520 3105 2700 3195 2970
1 1 1.00 90.00 180.00
5 1 0 1 0 7 50 0 -1 0.000 0 0 1 0 1462.500 2677.500 3465 1890 3600 2430 3600 2925
1 1 1.00 90.00 180.00
1 2 0 1 0 7 50 0 -1 0.000 1 0.0000 2070 2407 810 202 1260 2205 2880 2610
1 2 0 1 0 7 50 0 -1 0.000 1 0.0000 3352 1732 292 157 3060 1575 3645 1890
1 2 0 1 0 7 50 0 -1 0.000 1 0.0000 3555 3082 495 157 3060 2925 4050 3240
1 2 0 1 0 7 50 0 -1 0.000 1 0.0000 5467 2407 652 157 4815 2250 6120 2565
1 2 0 1 0 7 50 0 -1 0.000 1 0.0000 8820 1057 360 157 8460 900 9180 1215
1 2 0 1 0 7 50 0 -1 0.000 1 0.0000 10822 1732 562 157 10260 1575 11385 1890
1 2 0 1 0 7 50 0 -1 0.000 1 0.0000 9112 2407 697 157 8415 2250 9810 2565
1 2 0 1 0 7 50 0 -1 0.000 1 0.0000 7357 3757 742 202 6615 3555 8100 3960
1 2 0 1 0 7 50 0 -1 0.000 1 0.0000 9270 4432 855 202 8415 4230 10125 4635
1 2 0 1 0 7 50 0 -1 0.000 1 0.0000 10552 5107 292 157 10260 4950 10845 5265
1 2 0 1 0 7 50 0 -1 0.000 1 0.0000 10552 5107 382 247 10170 4860 10935 5355
1 2 0 1 0 7 50 0 -1 0.000 1 0.0000 7492 5107 877 202 6615 4905 8370 5310
1 2 0 1 0 7 50 0 -1 0.000 1 0.0000 5242 5782 427 157 4815 5625 5670 5940
1 2 0 1 0 7 50 0 -1 0.000 1 0.0000 4027 5107 1012 202 3015 4905 5040 5310
1 2 0 1 0 7 50 0 -1 0.000 1 0.0000 3780 6457 765 202 3015 6255 4545 6660
1 2 0 1 0 7 50 0 -1 0.000 1 0.0000 2025 4432 810 202 1215 4230 2835 4635
4 0 0 50 0 12 12 0.0000 4 180 840 3150 3150 body-bol\001
4 0 0 50 0 12 12 0.0000 4 180 420 3150 1800 body\001
4 0 0 50 0 12 12 0.0000 4 180 1050 4950 2475 body-match\001
4 0 0 50 0 12 12 0.0000 4 180 1470 1350 2475 body-bol-maybe\001
4 0 0 50 0 12 12 0.0000 4 135 1260 6750 3825 header-front\001
4 0 0 50 0 12 12 0.0000 4 135 1155 8550 2475 front-match\001
4 0 0 50 0 12 12 0.0000 4 135 525 8550 1125 front\001
4 0 0 50 0 12 12 0.0000 4 135 945 10350 1800 front-bol\001
4 0 0 50 0 12 12 0.0000 4 135 1365 1350 4500 header-border\001
4 0 0 50 0 12 12 0.0000 4 180 1785 3150 5175 header-cont-maybe\001
4 0 0 50 0 12 12 0.0000 4 135 1470 6750 5175 header-front-2\001
4 0 0 50 0 12 12 0.0000 4 135 1470 8550 4500 header-front-1\001
4 0 0 50 0 12 12 0.0000 4 135 420 10350 5175 back\001
4 0 0 50 0 12 12 0.0000 4 135 630 4950 5850 header\001
4 0 0 50 0 12 12 0.0000 4 135 1260 3150 6525 header-value\001
4 0 0 50 0 12 12 0.0000 4 75 315 10530 2475 '-'\001
4 0 0 50 0 12 12 0.0000 4 150 420 10035 990 '\\n'\001
4 0 0 50 0 12 12 0.0000 4 75 315 10395 4635 '-'\001
4 0 0 50 0 12 12 0.0000 4 75 315 8595 3825 '-'\001
4 0 0 50 0 12 12 0.0000 4 150 420 6255 5760 '\\n'\001
4 0 0 50 0 12 12 0.0000 4 120 315 4815 6345 ':'\001
4 0 0 50 0 12 12 0.0000 4 150 420 2835 5895 '\\n'\001
4 0 0 50 0 12 12 0.0000 4 120 315 4455 5625 ' '\001
4 0 0 50 0 12 12 0.0000 4 150 420 4410 5940 '\\t'\001
4 0 0 50 0 12 12 0.0000 4 150 420 3105 4185 '\\n'\001
4 0 0 50 0 12 12 0.0000 4 150 420 2115 3600 '\\n'\001
4 0 0 50 0 12 12 0.0000 4 150 420 2340 5130 '\\r'\001
4 0 0 50 0 12 12 0.0000 4 150 420 2700 2880 '\\n'\001
4 0 0 50 0 12 12 0.0000 4 150 420 2745 2160 '\\r'\001
4 0 0 50 0 12 12 0.0000 4 150 420 3645 2385 '\\n'\001
4 0 0 50 0 12 12 0.0000 4 75 315 4005 2745 '-'\001
fastcgi-cmucl/multipart.png 0100644 0003730 0001751 00000000000 07224625663 015325 0 ustar chery devel fastcgi-cmucl/test.lisp 0100644 0003730 0001751 00000005262 07224625252 014457 0 ustar chery devel (use-package :fastcgi)
(defclass request-factory ()
())
(defclass request (fastcgi-request)
((parts :accessor request-parts
:initform 0)
(blocks :accessor request-blocks
:initform nil)))
(defmethod make-fastcgi-request ((request-factory request-factory))
(make-instance 'request))
(defclass multipart-handler (fastcgi-multipart-handler)
())
(defmethod fastcgi-request-params-end ((request request))
(if (string= (caar (fastcgi-request-content-type request)) "multipart")
(setf (fastcgi-request-stdin-handler request)
(make-instance 'multipart-handler :request request))))
(defmethod mime-handle-data ((handler multipart-handler) buffer start end)
(when (string= (fastcgi-multipart-current-name handler) "kala")
(push (subseq buffer start end)
(request-blocks (fastcgi-multipart-request handler)))))
(defmethod mime-handle-body-end ((handler multipart-handler))
(incf (request-parts (fastcgi-multipart-request handler))))
(defmethod mime-handle-multipart-end ((handler multipart-handler))
(let ((request (fastcgi-multipart-request handler)))
(let ((o (fastcgi-request-output-stream request)))
(format o "Content-type: text/html~A"
(coerce '(#\Return #\Linefeed #\Return #\Linefeed) 'string))
(format o "Multipart")
(format o "Parts: ~A~%" (request-parts request))
(format o "Kala: ~A~%" (reverse (request-blocks request)))
(format o "")
(close o))
(fastcgi-send-end-request request 0 :request-complete)))
(defmethod fastcgi-request-stdin ((request request)
buffer start position)
(when (= start position)
(fastcgi-request-stdout request "Content-type: text/html")
(fastcgi-request-stdout request (coerce '(#\Return #\Linefeed)
'string))
(fastcgi-request-stdout request (coerce '(#\Return #\Linefeed)
'string))
(let ((o (fastcgi-request-output-stream request)))
(format o "Kala")
(format o "~A ~A" (fastcgi-request-uri request)
(fastcgi-request-content-type request))
(format o "
")
(loop for (name . value) in (fastcgi-request-params request)
do (format o "- ~A, ~A
" name (map 'string #'code-char value)))
(format o "
")
(close o))
(fastcgi-send-end-request request 0 :request-complete)))
(defun main ()
(profile:profile fastcgi::send-fastcgi-packet)
(profile:profile fastcgi::make-packet)
(profile:profile fastcgi::handle-fastcgi-packet-fragment)
; (fastcgi-dynamic-server (make-instance 'request-factory))
(fastcgi-external-unix-server "/tmp/fcgi/appserv.socket"
(make-instance 'request-factory)))