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 ((body-length (get-content-length req))) ;;make sure we have a valid Content-length header in request
    (make-response
     (status-code ok)
     #f
     (time)
     "text/html"
     '()
     (make-reader-writer-body
      (lambda (iport oport options)
	;;still buggy: if the body of the request is not a valid html-form-query
	;;or does not contain program=<stuff> we answer 200 but
	;;don't send a body (as read-request-sexp throws an exception)
	(let ((sexp (read-request-sexp body-length iport))) 
	  (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 2 "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 2 "Return value(s)")
					(with-tag oport pre ()
						  (for-each (lambda (val) (p val oport))
							    vals))))))))))))


;;; Read an HTTP request entity body from stdin. The Content-length:
;;; entity-header field of request REQ tells how many bytes 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 bytes iport)
  (let* 
      ((body (read-string bytes iport))   ;;read in bytes chars
       (parsed-html-form-query (parse-html-form-query body)) ;; and parse them up.
       (program (cond ((assoc "program" parsed-html-form-query) => cdr)
		      (else (error "No program in entity body.")))))
    (http-syslog (syslog-level debug)
		 "Seval sexp: ~s" program)
    (read (make-string-input-port program)))) ;; return first sexp, discard others


;; GET-NUMERIC-FIELD-VALUE
;; generalized function to get a field value of the form 1*DIGIT

;; check wether a header-field with name field-name is contained in req;
;; if so, check wether ist field-content conforms to 
;; field-content = *LWS 1*DIGIT *LWS
;; (i.e. optional leading whitespaces, at least one digit, optional trailing whitespace);
;; if so, return digit as a number

;; req is a request record, field-name a symbol
(define (get-numeric-field-value req field-name)
  (let* 
      ;;take first Content-length: header (RFC 2616 allows only one Content-length: header)
      ((field-content (get-header (request-headers req) field-name))
       (field-value-start (string-skip field-content char-set:whitespace));; skip whitespace, ;;char-set:whitespace = LWS from RFC2616?
       (field-value (if field-value-start			;;yes, field content contained non-whitespace chars
			(string->number (substring field-content   
						   field-value-start
						   (string-length field-content))) ;;trailing whitespace? RFC allows it! ->
			;; probably read-rfc822-headers in rfc822.scm should do the job of skipping leading and trailing whitespace?*
			(http-error (status-code bad-request) req 
				    (format #f "~A header contained only whitespace" field-name)))))
    (if (and (integer? field-value) (>= field-value 0)) ;;yes, field value contained only digits
	field-value
	(http-error (status-code bad-request) req
		    (format #f "~A header contained characters other than digits" field-name)))))


;;* RFC 2616, 4.2: The field-content does not include any leading or
;;trailing LWS: linear white space occurring before the first
;;non-whitespace character of the field-value or after the last
;;non-whitespace character of the field-value. Such leading or
;;trailing LWS MAY be removed without changing the semantics of the
;;field value.

(define (get-content-length req)
  (get-numeric-field-value req 'content-length))