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.

;;; (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 ...)))))

;;; The request handler for seval ops.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (seval-handler path req)
  (let ((request-method (request-method req)))
    (cond 
     ((string=? request-method "POST")	; Could do others also.
      (seval path req))
     ((or (string=? request-method "HEAD")
	  (string=? request-method "GET"))
      (make-error-response (status-code method-not-allowed) req 
				    "POST"))
     (else
      (make-error-response (status-code not-implemented) req)))))


(define (seval path req)
  (let* ((message-body (read-message-body req))
	(sexp (parse-request-sexp message-body)))
    (make-response
     (status-code ok)
     #f
     (time)
     "text/html"
     '()
     (make-writer-body
      (lambda (oport options)
	(http-syslog (syslog-level debug) "read sexp: ~a" sexp)
	(emit-prolog oport)
	(with-tag oport html (xmlnsdecl-attr)
		  (newline oport)
		  (with-tag oport head ()
			    (newline oport)
			    (emit-title oport "Scheme program output")
			    (newline oport))
		  (newline oport)
		  
		  (with-tag oport body ()
			    (newline oport)
			    (do/timeout 
			     10
			     (receive vals
				      ;; Do the computation.
				      (begin (emit-header oport 1 "Output from execution")
					     (newline oport)
					     (with-tag oport pre ()
						       (newline oport)
						       (force-output oport); In case we're gunned down.
						       (with-current-output-port oport
										 (eval-safely sexp))))
				      
				      ;; Pretty-print the returned value(s).;; hier noch mal newline rausschreiben?
				      (emit-header oport 1 "Return value(s)")
				      (with-tag oport pre ()
						(for-each (lambda (val) (p val oport))
							  vals)))))))))))


;;; Parse the request's message body.

;;; We assume, that the entity is "form-url encoded" data (see
;;; parse-forms.scm for a description of this encoding). This
;;; assumption is rather strange - it may safely be made only if
;;; there's a "Content-type: application/x-www-form-urlencoded" header.

;;; Pull out the program=<stuff> string, extract <stuff>, 
;;; parse that into an s-expression, and return it.

(define (parse-request-sexp body)
  (let* ((parsed-html-form-query (parse-html-form-query body))
	 (program (cond ((assoc "program" parsed-html-form-query) => cdr)
		      (else (fatal-syntax-error "No program was found in request's message body.")))))
    (http-syslog (syslog-level debug)
		 "Seval sexp: ~s" program)
    (with-fatal-error-handler 
     (lambda (c decline)
       (fatal-syntax-error "The program in the request's message body isn't a valid s-expression"))
     (read (make-string-input-port program))))) ;; return first sexp, discard others