Subject: [clisp-list] simple webserver running in clisp

From: [email-masked] (Don Cohen)
Date: Fri, 21 Jan 2000 12:58:46 -0800

Not too long ago someone asked for such a program.
I sent a version that I had modified from on distributed by Franz.
However, at the time it did not run in clisp.  I've now made the
few minor changes needed to run it in clisp, so without further ado:

;; 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
      (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)
	  (loop as ch = (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)))
		(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))