Switch branches/tags
save2011_02_16 release10.1_t6 release10.1_t5 release10.1_t4 release10.1_t3 release10.1_t2 release10.1_t1 release10.1_release_point release10.1_rc5 release10.1_rc4 release10.1_rc3 release10.1_rc2 release10.1_rc1 release10.1_beta3_release_point release10.1.beta2_release_point release10.1.beta_t6 release10.1.beta_t5 release10.1.beta_t4 release10.1.beta_t3 release10.1.beta_t2 release10.1.beta_t1 release10.1.beta_release_point release10.1.beta_rc4 release10.1.beta_rc3 release10.1.beta_rc2 release10.1.beta_rc1 release10.0_t3 release10.0_t2 release10.0_t1 release10.0_rc9 release10.0_rc8 release10.0_rc7 release10.0_rc6 release10.0_rc5 release10.0_rc4 release10.0_rc3 release10.0_rc2 release10.0_rc1 release10.0.pre-final.30_release_point release10.0.pre-final.17_release_point release10.0.beta_t13 release10.0.beta_t12 release10.0.beta_t11 release10.0.beta_t10 release10.0.beta_t9 release10.0.beta_t8 release10.0.beta_t7 release10.0.beta_t6 release10.0.beta_t5 release10.0.beta_t4 release10.0.beta_t3 release10.0.beta_t2 release10.0.beta_t1 release10.0.beta_release_point release10.0.beta_rc2 release10.0.beta_rc1 release_aclt2 release_acl100b14t8 release_acl100b11t7 release_acl100b10t6 release_acl100b8t5 release_acl100b7t4 release_acl100b6t3 release_acl100b4t2 release_acl100b2t1 release_acl90b21rc5 release_acl90b20_release_point release_acl90b20rc4 release_acl90b19rc3 release_acl90b18rc2 release_acl90b15_release_point release_acl90b15rc1 release_acl90b13t1 release_acl90b11t1 release_acl90b9t1 release_acl90b8t1 release_acl90b6_release_point release_acl90b6rc2 release_acl90b_release_point release_acl90a52rc1 release_acl90a44rc2 release_acl90a43rc1 release_acl90a39 release_acl90a39rc2 release_acl90a32 release_acl90a27 release_acl90a25 release_acl90a24 release_acl90a23 release_acl90a20 release_acl90a18 install-spider_2013-04-26T12-55-31 install-spider_2013-04-25T12-56-58 install-spider_2013-04-24T16-52-55 install-spider_2013-04-24T16-42-42 install-spider_2013-04-24T16-29-36 install-spider_2013-04-24T15-47-16 install-spider_2013-04-24T15-37-01 install-spider_2013-04-24T15-02-09 install-spider_2013-04-23T11-10-35
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
456 lines (371 sloc) 12.8 KB
;; -*- mode: common-lisp; package: net.aserve -*-
;; See the file LICENSE for the full license governing this code.
;; Description:
;; common gateway interface (running external programs)
;;- This code in this file obeys the Lisp Coding Standard found in
(in-package :net.aserve)
(eval-when (compile) (declaim (optimize (speed 3))))
(defun run-cgi-program (req ent program
(script-name (net.uri:uri-path (request-uri req)))
(query-string nil query-string-p)
(timeout 200)
;; program is a string naming a external command to run.
;; invoke the program after setting all of the environment variables
;; according to the cgi specification.
;; error-output can be
;; nil - inherit lisp's standard output
;; pathname or string - write to file of a given name
;; :output - mix in the error output with the output
;; function - call function when input's available from the error
;; stream
(declare (ignorable terminate)) ; not used in Windows
(let ((envs (list '("GATEWAY_INTERFACE" . "CGI/1.1")
. ,(format nil "AllegroServe/~a"
; error check the error argument
(typecase error-output
((or null pathname string)
(setq error-output-arg error-output))
(if* (eq error-output :output)
then (setq error-output-arg error-output)
else (setq error-output-arg :stream
error-fcn error-output)))
(setq error-output-arg :stream
error-fcn error-output))
(t (error "illegal value for error-output: ~s" error-output)))
(let ((our-ip (socket:local-host (request-socket req))))
(let ((hostname (socket:ipaddr-to-hostname our-ip)))
(if* (null hostname)
then (setq hostname (socket:ipaddr-to-dotted our-ip)))
(push (cons "SERVER_NAME" hostname) envs)))
(push (cons "SERVER_PROTOCOL"
(string-upcase (string (request-protocol req))))
(push (cons "SERVER_PORT"
(write-to-string (socket:local-port
(request-socket req))))
(push (cons "REQUEST_METHOD"
(string-upcase (string (request-method req))))
(if* path-info
then (push (cons "PATH_INFO" path-info) envs))
(if* path-translated
then (push (cons "PATH_INFO" path-translated) envs))
(if* script-name
then (push (cons "SCRIPT_NAME" script-name) envs))
(if* query-string-p
then (if* query-string
then (push (cons "QUERY_STRING" query-string) envs))
else ; no query string arg given, see if the uri
; for ths command has a query string
(let ((query (net.uri:uri-query
(request-uri req))))
(if* query
then (push (cons "QUERY_STRING" query) envs))))
(let ((their-ip (socket:remote-host (request-socket req))))
(let ((hostname (socket:ipaddr-to-hostname their-ip)))
(if* hostname
then (push (cons "REMOTE_HOST" hostname) envs)))
(push (cons "REMOTE_ADDR" (socket:ipaddr-to-dotted their-ip))
(if* auth-type
then (push (cons "AUTH_TYPE" auth-type) envs))
(if* (member (request-method req) '(:put :post))
then ; there is likely data coming along
(setq body (get-request-body req ))
(if* (equal body "") then (setq body nil)) ; trivial case
(let ((content-type (header-slot-value req :content-type)))
(if* content-type
then (push (cons "CONTENT_TYPE"
(push (cons "CONTENT_LENGTH"
(if* body then (length body) else 0)))
; now do the rest of the headers.
(dolist (head (listify-parsed-header-block (request-header-block req)))
(if* (and (not (member (car head) '(:content-type :content-length)
:test #'eq))
(cdr head))
then (push (cons (format nil "HTTP_~a"
(substitute #\_ #\-
(string (car head)))))
(cdr head))
(dolist (header env)
(if* (not (and (consp header)
(stringp (car header))
(stringp (cdr header))))
then (error "bad form for environment value: ~s" header))
(let ((ent (assoc (car header) envs :test #'equal)))
(if* ent
then ; replace value with user specified value
(setf (cdr ent) (cdr header))
else ; add new value
(push header envs))))
;; now to invoke the program
;; this requires acl6.1 on unix since this is the first version
;; that can set the environment variables for the run-shell-command
;; call
(run-shell-command program
:input (if* body then :stream)
:output :stream
:error-output error-output-arg
:separate-streams t
:wait nil
:environment envs
:show-window :hide)
(declare (ignore ignore-this))
; first send the body to the script
; maybe we should interleave reading and writing
; but that's a lot of work
(if* (and body to-script-stream)
then (write-sequence body to-script-stream)))
(if* to-script-stream
then (ignore-errors (close to-script-stream))
(setq to-script-stream nil))
; read the output from the script
(read-script-data req ent
from-script-stream from-script-error-stream
;; cleanup forms:
(if* to-script-stream
then (ignore-errors (close to-script-stream)))
(if* from-script-stream
then (ignore-errors (close from-script-stream)))
(if* from-script-error-stream
then (ignore-errors (close from-script-error-stream)))
(if* pid
then ;; wait for process to die
(if* (null (sys:reap-os-subprocess :pid pid :wait nil))
then ; not ready to die yet, but someone
; should wait for it to die while we return
(if* terminate
then ; forceably kill
(progn (unix-kill pid 15) ; sigterm
(sleep 2) ; give it a chance to die
(if* (sys:reap-os-subprocess :pid pid :wait nil)
then (setq pid nil) ; indicate killed
else (unix-kill pid 9) ; kill
(if* pid
then ; must have someone wait for the death
(mp::process-run-function "reaper"
#'(lambda ()
(dotimes (i 10)
(sleep (+ 2 (* i 10)))
(if* (sys:reap-os-subprocess :pid pid
:wait nil)
then (return))))))))))))
(defun read-script-data (req ent stream error-stream error-fcn timeout)
;; read from the stream and the error-stream (if given)
;; do the cgi header processing and start sending output asap
;; don't close the streams passed, they'll be closed by the caller
(let ((active-streams)
(start 0))
(labels ((error-stream-handler ()
;; called when data available on error stream.
;; calls user supplied handler function
(let ((retcode (funcall error-fcn req ent error-stream)))
(if* retcode
then ; signal to close off the error stream
(setq active-streams
(delete error-stream active-streams :key #'car)))))
(data-stream-header-read ()
;; called when data available on standard output
;; and we're still reading in search of a full header
(if* (>= start (length buff))
then ; no more room to read, must be bogus header
(failed-script-response req ent)
(return-from read-script-data)
else (let ((len (read-vector buff stream
:start start)))
(if* (<= len start)
then ; eof, meaning no header
(failed-script-response req ent)
(return-from read-script-data)
else (setq start len)
(multiple-value-bind (resp headers bodystart)
(parse-cgi-script-data buff start)
(if* resp
then ; got the header, switch
; to body
resp headers bodystart)
; never returns
(data-stream-body-process (resp headers bodystart)
;; called when it's time to start returning the body
(with-http-response (req ent :response resp
:format :binary)
(with-http-body (req ent :headers headers)
; write out first block
(write-all-vector buff
:start bodystart
:end start)
; now loop and read rest
(setf (cdr (assoc stream active-streams :test #'eq))
(if* (null active-streams)
then (return))
(let ((active
(mapcar #'car active-streams)
:timeout timeout)))
(if* (null active)
then ; timeout, just shut down streams
(setq active-streams nil)
else ; run handlers
(mapc #'(lambda (x)
(funcall (cdr (assoc x active-streams
:test #'eq))))
(return-from read-script-data))
(data-stream-body ()
;; process data coming back from the body
(let ((len (read-vector buff stream)))
(if* (<= len 0)
then ; end of file, remove this stream
(setq active-streams
(delete stream active-streams
:key #'car))
else ; send data to output
(write-all-vector buff
:start 0
:end len)
(force-output *html-stream*)))))
(setq active-streams
(list (cons stream #'data-stream-header-read)))
(if* error-stream
then (push (cons error-stream #'error-stream-handler)
(setq buff (get-header-block))
; this loop is for searching for a valid header
(let ((active
(mapcar #'car active-streams) :timeout timeout)))
(if* (null active)
then ; must have timed out
(failed-script-response req ent)
(return-from read-script-data))
; run the handlers
(mapc #'(lambda (x)
(funcall (cdr (assoc x active-streams :test #'eq))))
; cleanup
(free-header-block buff)))))
(defun failed-script-response (req ent)
;; send back a generic failed message
(with-http-response (req ent
:response *response-internal-server-error*
:content-type "text/html")
(with-http-body (req ent)
(html "The cgi script failed to run"))))
(defun parse-cgi-script-data (buff end)
;; if there's a valid header block in the buffer from 0 to end-1
;; then return
;; 1. the response object denoting the response value to send back
;; 2. a list of headers and values
;; 3. the index in the buffer where the data begins after the header
;; else return nil
(let* ((loc (search *crlf-crlf-usb8* buff
:end2 (min (length buff) end)))
(loclflf (and (null loc)
;; maybe uses bogus lf-lf to end headers
(search *lf-lf-usb8* buff
:end2 (min (length buff) end))))
(incr 2))
(if* loclflf
then (setq loc loclflf
incr 1))
(if* (null loc)
then ; hmm.. no headers..bogus return
;(warn "no headers found")
(return-from parse-cgi-script-data nil))
(incf loc incr) ; after last header crlf (lf), before final crlf (lf)
(let ((headers (parse-and-listify-header-block
(resp *response-ok*))
(incf loc incr) ; past the final crlf (lf)
(if* (assoc :location headers :test #'eq)
then (setq resp *response-moved-permanently*))
(let ((status (assoc :status headers :test #'eq))
(if* status
then (ignore-errors
(setq code (read-from-string (cdr status))))
(if* (not (integerp code))
then ; bogus status value, just return nil
; eventually we'll get a failed response
(format nil
"cgi script return bogus status value: ~s"
(return-from parse-cgi-script-data nil))
(let ((space (position #\space (cdr status))))
(if* space
then (setq reason
(subseq (cdr status) space))))
(setq resp (make-resp code reason))
(setq headers (delete status headers))))
(values resp headers loc))))
(defun write-all-vector (sequence stream &key (start 0)
(end (length sequence)))
;; write everything in the vector before returning
(if* (< start end)
then (setq start (write-vector sequence stream
:start start
:end end))
else (return)))