186 lines
7.3 KiB
Scheme
186 lines
7.3 KiB
Scheme
(define-library (eval-server)
|
|
(import (srfi 1)
|
|
(srfi 13)
|
|
(srfi 98)
|
|
(scheme base)
|
|
(scheme file)
|
|
(scheme write)
|
|
(only (chicken blob) blob->string)
|
|
(only (chicken file) create-temporary-directory)
|
|
(chicken process-context)
|
|
(chicken process)
|
|
(only (srfi 4) u8vector->blob)
|
|
(spiffy)
|
|
(intarweb)
|
|
(uri-common)
|
|
(tar))
|
|
(begin
|
|
|
|
(define implementations
|
|
'(("chibi" ("chibi-scheme"))
|
|
("gauche" ("gosh" "-r" "7"))))
|
|
|
|
(define implementation-name first)
|
|
(define implementation-command-line second)
|
|
|
|
(define (respond-with-error status string)
|
|
(send-response status: status body: string))
|
|
|
|
(define (bytevector->string bytes)
|
|
(blob->string (u8vector->blob bytes)))
|
|
|
|
(define (tar-for-each proc)
|
|
(let loop ()
|
|
(let ((entry (read-tar-entry)))
|
|
(unless (eof-object? entry)
|
|
(proc entry)
|
|
(loop)))))
|
|
|
|
(define (parse-null-terminated-strings bytes)
|
|
(let loop ((a 0) (b 0) (strings '()))
|
|
(if (= b (bytevector-length bytes))
|
|
(if (= a b)
|
|
(reverse strings)
|
|
(error "Missing final null terminator"))
|
|
(if (zero? (bytevector-u8-ref bytes b))
|
|
(loop (+ b 1) (+ b 1) (cons (utf8->string
|
|
(bytevector-copy bytes a b))
|
|
strings))
|
|
(loop a (+ b 1) strings)))))
|
|
|
|
(define (read-all-bytes port)
|
|
(let loop ((whole (bytevector)))
|
|
(let ((part (read-bytevector 10000 port)))
|
|
(if (eof-object? part) whole
|
|
(loop (bytevector-append whole part))))))
|
|
|
|
(define (parse-name-value-pair string)
|
|
(let loop ((i 0))
|
|
(cond ((= i (string-length string))
|
|
(error "No value"))
|
|
((char=? #\= (string-ref string i))
|
|
(cons (string-copy string 0 i)
|
|
(string-copy string (+ i 1) (string-length string))))
|
|
(else
|
|
(loop (+ i 1))))))
|
|
|
|
(define (tar-regular-file filename bytes)
|
|
(bytevector-append
|
|
(make-tar-header-for-regular-file filename bytes)
|
|
bytes (make-tar-padding bytes)))
|
|
|
|
(define (with-current-directory dir proc)
|
|
(let ((old-dir (current-directory)))
|
|
(dynamic-wind (lambda () (change-directory dir))
|
|
proc
|
|
(lambda () (change-directory old-dir)))))
|
|
|
|
(define (handle-the-scheme-implementation impl)
|
|
(let ((cmdline #f)
|
|
(environ #f)
|
|
(cwd (string->utf8 "/"))
|
|
(stdin (bytevector))
|
|
(stdout (bytevector))
|
|
(stderr (bytevector))
|
|
(files '()))
|
|
(parameterize ((current-input-port (request-port (current-request))))
|
|
(tar-for-each
|
|
(lambda (entry)
|
|
(let* ((name (tar-entry-name entry))
|
|
(bytes (read-tar-entry-bytes entry)))
|
|
(write name)(newline)
|
|
(cond ((or (equal? "" name)
|
|
(string-prefix? "/" name)
|
|
(string-prefix? "." name))
|
|
(error "Bad name" name))
|
|
((or (equal? "proc/" name)
|
|
(equal? "proc/self/" name)
|
|
(equal? "proc/self/fd/" name))
|
|
#f)
|
|
((equal? "proc/self/cmdline" name)
|
|
(set! cmdline (parse-null-terminated-strings bytes)))
|
|
((equal? "proc/self/environ" name)
|
|
(set! environ
|
|
(map parse-name-value-pair
|
|
(parse-null-terminated-strings bytes))))
|
|
((equal? "proc/self/cwd" name)
|
|
(set! cwd (utf8->string bytes)))
|
|
((equal? "proc/self/fd/0" name)
|
|
(set! stdin bytes))
|
|
((string-prefix? "proc/self/fd/" name)
|
|
(error "Bad proc/self/fd/ on input" name))
|
|
((string-prefix? "proc/" name)
|
|
(error "Bad /proc entry on input"))
|
|
((not (string-suffix? "/" name))
|
|
(set! files (cons (cons name bytes)
|
|
files))))))))
|
|
(write `(cmdline ,cmdline))(newline)
|
|
(write `(environ ,environ))(newline)
|
|
(write `(cwd ,cwd))(newline)
|
|
(write `(stdin ,stdin))(newline)
|
|
(unless (assoc "main.scm" files)
|
|
(error "No main.scm file in archive"))
|
|
(let ((tempdir (create-temporary-directory)))
|
|
(write tempdir)(newline)
|
|
(with-current-directory
|
|
tempdir
|
|
(lambda ()
|
|
(for-each (lambda (entry)
|
|
(let ((name (car entry))
|
|
(bytes (cdr entry)))
|
|
(call-with-port
|
|
(open-binary-output-file name)
|
|
(lambda (out) (write-bytevector bytes out)))))
|
|
files)
|
|
(let ((command (append (implementation-command-line impl)
|
|
(list "main.scm")
|
|
cmdline)))
|
|
(write command)(newline)
|
|
(let-values (((from-sub to-sub sub-pid from-sub-err)
|
|
(process* (car command) (cdr command) environ)))
|
|
(write-bytevector stdin to-sub)
|
|
(close-output-port to-sub)
|
|
(set! stdout (read-all-bytes from-sub))
|
|
(set! stderr (read-all-bytes from-sub-err)))))))
|
|
(send-response
|
|
status: 'ok
|
|
headers: `((content-type ,tar-content-type))
|
|
body: (bytevector->string
|
|
(bytevector-append
|
|
(tar-regular-file "proc/self/fd/1" stdout)
|
|
(tar-regular-file "proc/self/fd/2" stderr)
|
|
(make-tar-eof))))))
|
|
|
|
(define (handle-scheme-implementation)
|
|
(let ((path (uri-path (request-uri (current-request))))
|
|
(head (request-headers (current-request))))
|
|
(write (header-value 'content-type head))(newline)
|
|
(write (header-value 'accept head))(newline)
|
|
(if (not (and (tar-content-type? (header-value 'content-type head))
|
|
(tar-content-type? (header-value 'accept head))))
|
|
(respond-with-error 'bad-request "Not tar files")
|
|
(let* ((impl-name (second path))
|
|
(impl (assoc impl-name implementations)))
|
|
(if (not impl)
|
|
(respond-with-error 'not-found
|
|
"No such Scheme implementation")
|
|
(handle-the-scheme-implementation impl))))))
|
|
|
|
(define (handle-request continue)
|
|
(let ((path (uri-path (request-uri (current-request)))))
|
|
(write path)(newline)
|
|
(if (and (= 2 (length path))
|
|
(eq? '/ (first path))
|
|
(string? (second path)))
|
|
(handle-scheme-implementation)
|
|
(continue))))
|
|
|
|
(define (main)
|
|
(vhost-map `(("localhost" . ,handle-request)))
|
|
(server-port
|
|
(string->number (or (get-environment-variable "PORT")
|
|
(error "No PORT"))))
|
|
(start-server))
|
|
|
|
(main)))
|