145 lines
5.0 KiB
Scheme
145 lines
5.0 KiB
Scheme
;;; 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,
|
|
;; FIXME where is the input port?
|
|
(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))))
|