sunet/scheme/httpd/seval.scm

;;; Path handler for uploading Scheme code to the SU web server -*- Scheme -*-

;;; This file is part of the Scheme Untergrund Networking package.

;;; Copyright (c) 1995 by Olin Shivers.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.

;;; This is really just an handler example demonstrating how to upload code 
;;; into the server.

;;; HTML forms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This path handler is suitable for receiving code entered into an
;;; HTML text form. The Scheme code being uploaded is being POST'd to us
;;; (from a form). See http-forms.scm for info on the format of this kind
;;; of request. After parsing the request into the submitted string, we
;;; parse *that* into a Scheme sexp with READ, and eval it.

;;; (do/timeout secs thunk)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Run THUNK, and gun it down if it hasn't finished in SECS seconds.
;;; Returns nothing useful, and THUNK gets executed in a subprocess,
;;; so its side-effects are invisible, as well. This is a clever kludge --
;;; it uses three subprocesses -- but I don't have interrupts, so I'm hosed.

(define (do/timeout* secs thunk)
  (run (begin (let ((timer  (fork (lambda () (sleep secs))))
		    (worker (fork thunk)))
		(receive (process status) (wait-any)
		  (ignore-errors
		   (lambda ()
		     (signal-process (proc:pid (if (eq? worker process)
						   timer
						   worker))
				     signal/kill))))))))
(define-syntax do/timeout
  (syntax-rules ()
    ((do/timeout secs body ...) (do/timeout* secs (lambda () body ...)))))

(define-condition-type 'seval-error '())
(define seval-error? (condition-predicate 'seval-error))

(define-condition-type 'seval-no-content-length-error '(seval-error))
(define seval-no-content-length-error? 
  (condition-predicate 'seval-no-content-length-error))

(define-condition-type 'seval-no-program '(seval-error))
(define seval-no-program? (condition-predicate 'seval-no-program))

;;; The path handler for seval ops.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (seval-handler path req)
  (let ((request-method (request:method req)))
    (cond 
     ((string=? request-method "POST")	; Could do others also.
      (call-with-current-continuation
       (lambda (exit)
	 (begin
	   (with-handler
	    (lambda (condition more)
	      (exit
	       (cond
		((seval-no-content-length-error? condition)
		 (make-http-error-response 
		  http-status/bad-request req
		  "No `Content-length:' field in POST request."))
		((seval-no-program?  condition)
		 (make-http-error-response http-status/bad-request req
					   "No program in entity body."))
		(else
		 (make-http-error-response 
		  http-status/internal-error req
		  "Unknown error while evaluating seval-expression."
		  condition)))))
	    (lambda ()
	      (seval path req)))))))
     
     (else
      (make-http-error-response http-status/method-not-allowed req)))))

(define (seval path req)
  (let ((sexp (read-request-sexp req)))
    (http-syslog (syslog-level debug) "read sexp: ~a" sexp)
    (make-response
     http-status/ok
     (status-code->text http-status/ok)
     (time)
     "text/html"
     '()
     (make-writer-body
      (lambda (port options)
	(with-tag port HEAD ()
	  (newline port)
	  (emit-title port "Scheme program output"))
	(newline port)
	
	(with-tag port BODY ()
	  (newline port)
	  (do/timeout 
	   10
	   (receive vals
	       ;; Do the computation.
	       (begin (emit-header port 2 "Output from execution")
		      (newline port)
		      (with-tag port PRE ()
			(newline port)
			(force-output port); In case we're gunned down.
			(eval-safely sexp)))
	     
	     ;; Pretty-print the returned value(s).
	     (emit-header port 2 "Return value(s)")
	     (with-tag port PRE ()
	       (for-each (lambda (val) (p val port))
			 vals))))))))))


;;; Read an HTTP request entity body from stdin. The Content-length:
;;; element of request REQ's header tells how many bytes to this entity
;;; is. The entity should be a URI-encoded form body. Pull out the
;;;     program=<stuff>
;;; string, extract <stuff>, uri-decode it, parse that into an s-expression,
;;; and return it.

(define (read-request-sexp req)
  (cond 
   ((get-header (request:headers req) 'content-length) =>
    (lambda (cl-str)		 ; Take the first Content-length: header,
      (let* ((cl-start (string-skip cl-str char-set:whitespace))	   ; skip whitespace,
	     (cl (if cl-start			   	   ; & convert to
		     (string->number (substring cl-str   ;     a number.
						cl-start
						(string-length cl-str)))
		     0)) ; All whitespace?? -- WTF.
	     (qs (read-string cl))			; Read in CL chars,
	     (q (parse-html-form-query qs))		; and parse them up.
	     (s (cond ((assoc "program" q) => cdr)
		      (else (signal 'seval-no-program)))))
	(http-syslog (syslog-level debug)
		     "Seval sexp: ~s" s)
	(read (make-string-input-port s)))))
   (else (signal 'seval-no-content-length-error))))