Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Removing files not present on branch acl61beta:

	.cvsignore
	cgi.cl
	doc/cvs.html
	examples/cgitest.sh
  • Loading branch information...
commit 88d1863a89fee39de49d346e3fd8ccbb840d0052 1 parent f96812c
branch-fixup authored
Showing with 0 additions and 624 deletions.
  1. +0 −2  .cvsignore
  2. +0 −434 cgi.cl
  3. +0 −144 doc/cvs.html
  4. +0 −44 examples/cgitest.sh
View
2  .cvsignore
@@ -1,2 +0,0 @@
-build.tmp
-aserve-src
View
434 cgi.cl
@@ -1,434 +0,0 @@
-;; -*- mode: common-lisp; package: net.aserve -*-
-;;
-;; cgi.cl
-;;
-;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
-;;
-;; 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
-;;
-;;
-;; $Id: cgi.cl,v 1.5 2001/10/17 22:32:44 jkf Exp $
-
-;; Description:
-;; common gateway interface (running external programs)
-
-;;- This code in this file obeys the Lisp Coding Standard found in
-;;- http://www.franz.com/~jkf/coding_standards.html
-;;-
-
-
-(in-package :net.aserve)
-
-(defun run-cgi-program (req ent program
- &key
- path-info
- path-translated
- script-name
- (query-string nil query-string-p)
- auth-type
- (timeout 200)
- error-output
- )
- ;; 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.
- ;; http://hoohoo.ncsa.uiuc.edu/cgi/interface.html
- ;;
- ;; 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
- (let ((envs (list '("GATEWAY_INTERFACE" . "CGI/1.1")
- `("SERVER_SOFTWARE"
- . ,(format nil "AllegroServe/~a"
- *aserve-version-string*))))
- (error-output-arg)
- (error-fcn)
- (body))
-
- ; error check the error argument
- (typecase error-output
- ((or null pathname string)
- (setq error-output-arg error-output))
- (symbol
- (if* (eq error-output :output)
- then (setq error-output-arg error-output)
- else (setq error-output-arg :stream
- error-fcn error-output)))
- (function
- (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))))
- envs)
-
- (push (cons "SERVER_PORT"
- (write-to-string (socket:local-port
- (request-socket req))))
- envs)
-
- (push (cons "REQUEST_METHOD"
- (string-upcase (string (request-method req))))
- envs)
-
- (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))
- envs))
-
- (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"
- content-type)
- envs))
- (push (cons "CONTENT_LENGTH"
- (princ-to-string
- (if* body then (length body) else 0)))
- envs)))
-
- ; 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-upcase
- (string (car head)))))
- (cdr head))
- 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
-
- (multiple-value-bind
- (to-script-stream
- from-script-stream
- from-script-error-stream
- pid)
- (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))
-
- (unwind-protect
- ; first send the body to the script
- ; maybe we should interleave reading and writing
- ; but that's a lot of work
- (progn
- (ignore-errors
- (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
- error-fcn
- timeout))
-
-
- ;; 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 ;; it may be bad to wait here...
- (mp:with-timeout (60) ; ok w-t
- (sys:reap-os-subprocess :pid pid :wait t)))))))
-
-
-(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)
- (buff)
- (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-sequence 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
- (data-stream-body-process
- 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
- *html-stream*
- :start bodystart
- :end start)
-
- ; now loop and read rest
- (setf (cdr (assoc stream active-streams :test #'eq))
- #'data-stream-body)
-
- (loop
- (if* (null active-streams)
- then (return))
-
- (let ((active
- (mp:wait-for-input-available
- (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))))
- active)
-
- )))))
- (return-from read-script-data))
-
- (data-stream-body ()
- ;; process data coming back from the body
- (let ((len (read-sequence 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
- *html-stream*
- :start 0
- :end len)))))
-
-
- (setq active-streams
- (list (cons stream #'data-stream-header-read)))
-
- (if* error-stream
- then (push (cons error-stream #'error-stream-handler)
- active-streams))
-
- (unwind-protect
- (progn
- (setq buff (get-header-block))
-
-
-
- (loop
- ; this loop is for searching for a valid header
-
- (let ((active
- (mp:wait-for-input-available
- (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))))
- active))))
- ; 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
- buff
- loc))
- (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))
- code
- reason)
-
- (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
- (logmess
- (format nil
- "cgi script return bogus status value: ~s"
- code))
- (return-from parse-cgi-script-data nil))
- (let ((space (find #\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
- (loop
- (if* (< start end)
- then (setq start (write-vector sequence stream
- :start start
- :end end))
- else (return)))
-
- end)
-
-
View
144 doc/cvs.html
@@ -1,144 +0,0 @@
-<html>
-
-<head>
-<title>cvs</title>
-<meta name="GENERATOR" content="Microsoft FrontPage 3.0">
-</head>
-
-<body>
-
-<p><strong>Cvs </strong>allows you to automatically merge in the changes we make to
-Allegro aserve to a copy of the source you may have modified.&nbsp;&nbsp; This is much
-easier and less error prone than trying to see what we've changed by comparing source
-distributions and then merging in the changes yourself.&nbsp;&nbsp; A copy of the <strong>cvs</strong>
-document in <strong>pdf</strong> format is <a href="ftp://ftp.franz.com/pub/misc/cvs.pdf">here</a>.&nbsp;
-On our server we are using 1.10.7 of <strong>cvs</strong>, so you'll want to make sure
-your <strong>cvs</strong> client is compatible with that version.</p>
-
-<p>To access our repository via <strong>cvs</strong> here are the parameters you'll need:</p>
-
-<table border="0" width="58%" style="border: medium none" bgcolor="#FFFF00">
- <tr>
- <td width="22%"><strong>CVSROOT</strong></td>
- <td width="87%"><font face="Courier New">:pserver:cvspublic@cvspublic.franz.com:/cvs-public</font></td>
- </tr>
- <tr>
- <td width="22%"><strong>password</strong></td>
- <td width="87%"><font face="Courier New">cvspublic</font></td>
- </tr>
-</table>
-
-<p>If you use the <strong>-d</strong> parameter as shown below you won't need to set the <strong>CVSROOT</strong>
-environment variable.&nbsp; </p>
-
-<p>Here is a sample session where you check out aserve for the first time. &nbsp;&nbsp;
-First you have to save the password for the account on your machine, and you do that using
-the <strong>cvs login</strong> command:</p>
-
-<pre>% <strong>cvs -d :pserver:cvspublic@cvspublic.franz.com:/cvs-public login</strong>
-(Logging in to cvspublic@cvspublic.franz.com)
-CVS password: <strong>cvspublic</strong>
-</pre>
-
-<p>Next you check out the source code:</p>
-
-<pre>
-% <strong>cvs -d :pserver:cvspublic@cvspublic.franz.com:/cvs-public checkout aserve</strong>
-cvs server: Updating aserve
-U aserve/ChangeLog
-U aserve/authorize.cl
-U aserve/client.cl
-U aserve/decode.cl
-U aserve/license-lgpl.txt
-U aserve/load.cl
-U aserve/loadonly.cl
-U aserve/log.cl
-U aserve/macs.cl
-U aserve/main.cl
-U aserve/parse.cl
-U aserve/publish.cl
-U aserve/readme.txt
-U aserve/source-readme.txt
-cvs server: Updating aserve/doc
-U aserve/doc/aserve.html
-U aserve/doc/notes-neo.n
-U aserve/doc/rfc2396.txt
-U aserve/doc/tutorial.html
-cvs server: Updating aserve/examples
-U aserve/examples/examples.cl
-U aserve/examples/foo.txt
-U aserve/examples/fresh.jpg
-U aserve/examples/aservelogo.gif
-U aserve/examples/prfile9.jpg
-U aserve/examples/tutorial.cl
-cvs server: Updating aserve/htmlgen
-U aserve/htmlgen/htmlgen.cl
-U aserve/htmlgen/htmlgen.html
-U aserve/htmlgen/test.cl
-%
-
-</pre>
-
-<p>Now you can read <font face="Courier New">aserve/source-readme.txt</font> and learn how
-to build aserve.&nbsp;&nbsp; </p>
-
-<p>To see how <strong>cvs</strong> can help you, suppose you edit <font face="Courier New">aserve/examples/examples.cl</font>
-and add a new page to be published.&nbsp; You can ask <strong>cvs</strong> to tell you
-what you've changed since you last retrieved the source from our repository:&nbsp; </p>
-
-<pre>% <strong>cd aserve</strong>
-
-% <strong>cvs diff</strong>
-cvs server: Diffing .
-cvs server: Diffing doc
-cvs server: Diffing examples
-Index: examples/examples.cl
-===================================================================
-RCS file: /cvs-public/aserve/examples/examples.cl,v
-retrieving revision 1.2
-diff -r1.2 examples.cl
-369a370,378
-&gt;
-&gt; (publish :path &quot;/hiworld&quot;
-&gt; : content-type &quot;text/html&quot;
-&gt; :function
-&gt; #'(lambda (req ent)
-&gt; (with-http-response (req ent)
-&gt; (with-http-body (req ent)
-&gt; &quot;hi world&quot;))))
-&gt;
-cvs server: Diffing htmlgen
-%
-
-</pre>
-
-<p>You would now like to retrieve the latest version of the source from our repository and
-merge our changes into your changes.&nbsp;&nbsp; This is done with one command: executed
-from the aserve directory created in the <strong>cvs checkout</strong> command:</p>
-
-<pre>% <strong>cvs update -d</strong>
-cvs server: Updating .
-P client.cl
-cvs server: Updating doc
-cvs server: Updating examples
-M examples/examples.cl
-cvs server: Updating htmlgen
-%</pre>
-
-<p>The response from the command is terse.&nbsp; In this case the <strong>P </strong>before
-<font face="Courier New">client.cl</font> says that there were changes to that file in the
-repository that have now been patched into your copy of the source.&nbsp; The <strong>M</strong>
-before <font face="Courier New">examples/examples.cl</font> says that you have local
-modifications to this file.&nbsp; If you see a file name preceded by <strong>U </strong>(as
-they were in the <strong>cvs update</strong> command earlier), it means that this a new
-file that was downloaded in full.&nbsp; What you must look for is the response <strong>C</strong>
-which said that the updating process found conflicts that it couldn't resolve because both
-we and you modified the same lines in the file.&nbsp;&nbsp; In this case you must edit the
-file and look for the lines surrounded by &lt;&lt;&lt;&lt;&lt;&lt;&lt;&lt;&lt;&lt;,
-========= and &gt;&gt;&gt;&gt;&gt;&gt;&gt;&gt;&gt;&gt; and remove the markers and resolve
-the conflict</p>
-
-<p>We've just mentioned a few of the features of <strong>cvs,</strong> you are advised to
-read the<strong> cvs</strong> manual to get the maximum benefit from it<strong>.</strong></p>
-</body>
-</html>
View
44 examples/cgitest.sh
@@ -1,44 +0,0 @@
-#! /bin/sh
-#
-# return various cgi responses based on the first argument
-#
-case $1 in
-
- 1) # bogus but common lf headers
- echo 'Content-Type: text/plain'
- echo
- echo "The environment vars are "
- env
- echo "==== end ===="
- ;;
-
- 2) # redirect to franz.com, send some headers
- echo 'Location: http://www.franz.com'
- echo 'etag: 123hellomac'
- echo
- echo -n 'go to franz'
- ;;
-
- 3) # send back unauthorized request
- echo 'Status: 401 unauthorized request'
- echo
- echo 'this request unauthorized'
- ;;
-
- 4) # send back an ok response and something on the error stream
- echo 'Content-Type: text/plain
-'
- echo '
-'
- echo "okay"
- echo stuff-on-error-stream 1>&2
- ;;
-
- *) # normal crlf headers
- echo 'Content-Type: text/plain
-'
- echo '
-'
- echo "The environment vars are "
- env
- echo "==== end ===="
Please sign in to comment.
Something went wrong with that request. Please try again.