From: <do...@co...> - 2000-01-23 00:50:43
|
Two problems found in the last version are fixed here: - Bruno pointed out a missing #+clisp, which does no harm as long as you're trying to run it in clisp. - I discovered that trying to serve binary files (like images) failed due to errors reading bytes that cannot be converted to characters. Perhaps if problems continue to show up we can just put a copy in the ftp2.cons.org/pub/lisp/clisp archive, and then update that and announce the changes rather than reposting. ================ ;; simple web server ;; Copyright Franz Inc., 1997 ;; Permission is granted to copy, modify, or use the code ;; in this file freely, provided the copyright notice is preserved. ;; *** modifications by donc marked with *** #| general directions: 1. Load this file (which in turn requires socket and regexp libraries). 2. Set *webserver-commands* to a list of symbols that are allowed to be FUNCALLed by the webserver. These can be in any package, but two symbols with the same name in different packages won't work. (On input only the function name is available, not the package.) 3. Set log-file to the name of a file if you want a log kept. (To customize the contents see calls to log- below.) 4. Set *server-root* to a pathname of a directory. The server will only retrieve files below that directory. 5. (start-server :port ...)) As a sample, try - (setf *webserver-commands* '(print)) - install the following text in the file <*server-root*>/sample.html <FORM METHOD="POST" action="PRINT"> <br>username:<INPUT TYPE="text" NAME="user"> <br>password:<INPUT TYPE="password" NAME="pass"> <br><input type="submit" name="submit" value="try it"></form> - in your browser type in the url http://<your host>:<your port>/sample.html You should see a form with input fields labeled username and password and a "try it" button. When you press the button the data is sent to the server which calls the print funtion (the action above) on the inputs and the stream where the answer is expected. The input arguments are then printed in your browser. Now just replace print by a function that does what you want. |# ;; This demonstration server works under these versions of Allegro CL: ;; ACLWin 3.0.1 Lite ;; ACLWin 3.0.2 Lite ;; ACLWin 3.0.2 Professional ;; ACL 4.3 for Unix ;; *** also works for ACL 5.0, 5.0.1 ;; *** now also works for clisp (in-package :user) #+allegro ;; *** generalize from ACL (eval-when (compile load eval) (require :socket #+aclpc "fsl\\socket.fsl") ; load the socket code (require :regexp #+aclpc "fsl\\regexp.fsl") ; load the regular expression matcher ) ;; All files should be in this directory and below (defparameter *server-root* (pathname #+aclpc "c:\\tmp\\" #-aclpc "/usr/tmp/web/")) (defvar *webserver-commands* nil) ;; set this to the list of commands that are allowed ;; *** changed all the format t 's below to log's (defvar log-file nil) ;; set this to a file name in order to log transactions to that file (defun log- (&rest args) (when log-file (with-open-file (log log-file :direction :output :if-does-not-exist :create :if-exists :append) (apply 'format log args)))) (defun print-current-time (&optional (stream *standard-output*)) (multiple-value-bind (second minute hour day month year) (get-decoded-time) (format stream "~@?" "~d/~d/~d ~2,'0d:~2,'0d:~2,'0d" month day year hour minute second))) (defun start-server (&key (port 8000)) ;; start the web server running on the given port. ;; Note that on unix, ports below 1024 can only be obtained by ;; programs running as root. ;; The default port number for web browsers is 80, to use any other ;; port number in a url you have to put that port number after the ;; machine name as in http://www.foo.com:8000/the/url/I/want ;; (let ((websocket ;; *** generalize from ACL #+clisp (lisp:socket-server port) #+allegro (socket:make-socket :connect :passive :local-port port))) (unwind-protect (loop ;; It turns out that all the stream operations can and in ;; practice do generate errors. ;; The practical solution is to put an ignore-errors ;; at a pretty high level. (multiple-value-bind (ignore err) ;; *** (ignore-errors (let ((connection ;; *** generalize from ACL #+clisp (lisp:socket-accept websocket) #+allegro (socket:accept-connection websocket))) (unwind-protect (do-command connection #'(lambda () (return-from start-server))) (close connection)))) (declare (ignore ignore)) (when err (log- "~%error : ~A" err)))) ;; *** generalize from ACL #+clisp (lisp:socket-server-close websocket) #+allegro (close websocket)))) (defun do-command (stream exit-fcn) ;; Read the command from the web browser and execute it. ;; If the command indicates that the web server should go away, ;; then funcall the exit-fcn. (let ((command (read-line stream nil ""))) ;; got eof ?? *** (log- "~%Got command on ~s of ~s" stream command) ;; ;; A command from the browser is one line containing ;; two or three items separated by spaces. ;; The first item is the command (get, put, post) and the ;; second item is the url. ;; The third (and optional) item is the protocol. ;; The protocol determines how we must respond to the command. ;; If the protocol item is missing we assume http/0.9. If it is preset ;; then we only support http/1.0 ;; ;; For brevity, we use the new regular expression parser to break up the ;; command line into items, but this could also be done with ;; standard Common Lisp functions. ;; ;; *** replace regexp with ansi cl code (multiple-value-bind (matched whole-match cmd url protocol) #+ignore ;; replace with parse-http-command below (match-regexp "^\\([^ ]+\\) +\\([^ ]+\\) *\\([a-zA-Z/0-9.]*\\)" command) (parse-http-command command) (declare (ignore whole-match)) ;; replace non-ansi if* syntax (if matched (cond ((equalp cmd "GET") (log- "~%at ~A get ~s with protocol ~s" (print-current-time nil) url protocol) (when (equal url "/quit") (funcall exit-fcn)) (send-file stream url protocol)) ((equalp cmd "POST") (log- "~%at ~A post ~s with protocol~s" (print-current-time nil) url protocol) (post-command url stream)) (t (send-failure stream (format nil "I can't do command ~s" cmd) protocol))) (log- "~%command ~s is not in the right format" command))) (finish-output stream) ;; *** added - I don't know if it really matters ;; but I was getting clients thinking they had not seen complete files. )) ;; *** replacement for above match-regexp (defun parse-http-command (command) (let (cend ustart uend pstart pend) (setf cend (position #\space command) ustart (and cend (> cend 0) (position #\space command :start cend :test-not #'eql)) uend (and ustart (position #\space command :start ustart)) pstart (and uend (position #\space command :start uend :test-not #'eql)) pend (and pstart (position-if-not (lambda (c) (or (alphanumericp c) (eql c #\/) (eql c #\.))) command :start pstart))) (when ustart (values t (subseq command 0 (or pend (and pstart (length command)) uend (length command))) (subseq command 0 cend) (subseq command ustart uend) (if pstart (subseq command pstart pend) ""))))) (defun send-file (stream url protocol) ;; we've been given a 'get' command. We now must get the requested ;; item and send it to the web browser. ;; We're assuming that all items requested are html, gif, jpg, or jpeg. ;; We should check that '..' doesn't appear in a directory name ;; or a user could use that to navigate out of the *server-root* ;; directory and into any directory on the machine. (let ((file-location (merge-pathnames (pathname (subseq url 1)) *server-root*))) ;; *** replace non-ansi if* syntax (if (let ((probe (probe-file file-location))) (or (not probe) ;; *** test that we're under *server-root* (< (length (pathname-directory probe)) (length (pathname-directory *server-root*))) (loop for x in (pathname-directory probe) as y in (pathname-directory *server-root*) thereis (not (equal x y))) ;; *** also reject directories, since otherwise open errs (null (pathname-name probe)))) (send-failure stream (format nil "url ~s doesn't exist" url) protocol) (let ((binaryp nil) (type (pathname-type file-location))) (cond ((or (string-equal type "jpg") (string-equal type "jpeg")) (setq binaryp t type "image/jpeg")) ((string-equal type "gif") (setq binaryp t type "image/gif")) (t ;html? -- hope for the best (setq type "text/html"))) (when (equalp protocol "http/1.0") (format stream "HTTP/1.0 200 OK") (endline stream) (format stream "Content-type: ~a" type) (endline stream) (endline stream)) (with-open-file (f file-location ;; *** not all char codes valid #+clisp :element-type #+clisp '(unsigned-byte 8)) #+clisp ;; *** (setf (stream-element-type stream) '(unsigned-byte 8)) (loop as ch = (#+clisp read-byte #-clisp read-char f nil nil) ;; *** as i from 0 ;; debugging while ch do ;;(write-char ch) ;; debugging (when (eq ch #\newline) (unless binaryp (write-char #\return stream))) (#+clisp write-byte #-clisp write-char ch stream) ;; *** finally (log- "~%~A chars sent" i) ;; debugging ) ;;(sleep 1) ;; debugging ))))) (defun endline (stream) ;; most network protocols require that lines end with a ;; #\return character followed by a #\newline character (write-char #\return stream) (write-char #\linefeed stream)) (defun send-failure (stream message protocol) ;; something was wrong with the browser's request so send back a ;; message (when (equalp protocol "http/1.0") (format stream "HTTP/1.0 200 OK") (endline stream) (format stream "Content-type: text/plain") (endline stream) (endline stream)) (write-string message stream)) (defun post-command (url stream) ;; first we strip off the leading "\" from the url ;; then we look up the lisp function corresponding to the remaining string (let ((function ;; *** (read-from-string (subseq url 1 (length url))) ;; read-from-string is a really bad security hole ;; find-symbol would be better, but in order to allow ;; functions from different packages I prefer (loop for c in *webserver-commands* with name = (subseq url 1 (length url)) thereis (and (equal name (symbol-name c)) c)))) ;; parse through the header information until we get a blank line ;; which separates the data from the header (loop until (zerop (length (string-trim '(#\return) (read-line stream nil ""))))) ;*** ;; Now comes the form input. (let ((input (read-line stream nil ""))); *** ;; (log- "~%Input is ~s" input) (let ((args (parse-form-contents input))) (log- "~%Args are ~s" args) (if function ;; *** (funcall function args stream) (log- "~%~illegal function - ~A" url)))))) (defun parse-form-contents (contents) ;; input values come in the pairs name=value, delimited by & name is a ;; "name" specified in the HTML form value is the string input or ;; selection by the user on this form special cases like ? and & are ;; ignored in this parser. ;; return a list of dotted pairs (("name" . "value") ....) (loop with len = (length contents) with start = 0 for sep = (position #\& contents :start start) for end = (or sep len) for varend = (position #\= contents :start start) for sym = (subseq contents start varend) for val = (subseq contents (1+ varend) end) collect (cons sym (html-to-ascii val)) ;; *** until (null sep) do (setq start (1+ sep)))) ;; *** (defun html-to-ascii (string) ;; recover the real chars the user sent ;; translate + to space and %xx where xx is two hex digits ;; to that character in hex (let* ((chars (loop with pos = 0 while (< pos (length string)) collect (if (eql (char string pos) #\+) (progn (incf pos) #\space) (if (eql (char string pos) #\%) (prog1 (code-char (parse-integer string :start (+ pos 1) :end (+ pos 3) :radix 16)) (incf pos 3)) (prog1 (char string pos) (incf pos)))))) (ans (make-string (length chars)))) (loop for i from 0 as c in chars do (setf (char ans i) c)) ans)) |
From: Sam S. <sd...@gn...> - 2000-01-24 17:31:57
|
many functions here can be found in cllib/url.lsp (which is more client-oriented though) -- Sam Steingold (http://www.podval.org/~sds) Micros**t is not the answer. Micros**t is a question, and the answer is Linux, (http://www.linux.org) the choice of the GNU (http://www.gnu.org) generation. Live Lisp and prosper. |