159 lines
6.1 KiB
Scheme
159 lines
6.1 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.
|
|
|
|
;;; (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 not, return #f,
|
|
;; if there is one, check wether its 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)))
|
|
(if field-content
|
|
(let*
|
|
((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))))
|
|
#f)))
|
|
|
|
|
|
|
|
|
|
;;* 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)
|
|
(let ((maybe-length (get-numeric-field-value req 'content-length)))
|
|
(or maybe-length
|
|
(http-error (status-code bad-request) req "No Content-Length header in request"))))
|
|
|
|
|