100 lines
3.7 KiB
Plaintext
100 lines
3.7 KiB
Plaintext
|
(define-library (eval-server)
|
||
|
|
(import (srfi 1)
|
||
|
|
(srfi 13)
|
||
|
|
(srfi 98)
|
||
|
|
(scheme base)
|
||
|
|
(scheme write)
|
||
|
|
(only (chicken blob) blob->string)
|
||
|
|
(only (srfi 4) u8vector->blob)
|
||
|
|
(spiffy)
|
||
|
|
(intarweb)
|
||
|
|
(uri-common)
|
||
|
|
(tar))
|
||
|
|
(begin
|
||
|
|
|
||
|
|
(define implementations
|
||
|
|
'(("gauche" '("gosh" "-r" "7"))))
|
||
|
|
|
||
|
|
(define implementation-name first)
|
||
|
|
|
||
|
|
(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 (handle-the-scheme-implementation impl)
|
||
|
|
(let ((cmdline #f)
|
||
|
|
(environ #f)
|
||
|
|
(cwd (string->utf8 "/"))
|
||
|
|
(fd0 #f))
|
||
|
|
(parameterize ((current-input-port (request-port (current-request))))
|
||
|
|
(tar-for-each
|
||
|
|
(lambda (entry)
|
||
|
|
(let ((name (tar-entry-name entry)))
|
||
|
|
(write name)(newline)
|
||
|
|
(cond ((equal? "proc/self/cmdline" name)
|
||
|
|
(set! cmdline (read-tar-entry-bytes)))
|
||
|
|
((equal? "proc/self/environ" name)
|
||
|
|
(set! stdin (read-tar-entry-bytes)))
|
||
|
|
((equal? "proc/self/cwd" name)
|
||
|
|
(set! stdin (read-tar-entry-bytes)))
|
||
|
|
((equal? "proc/self/fd/0" name)
|
||
|
|
(set! stdin (read-tar-entry-bytes)))
|
||
|
|
((string-prefix? "proc/self/fd/" name)
|
||
|
|
(error "Bad file descriptor on input"))
|
||
|
|
((or (equal? "proc" name) (string-prefix? "proc/" name))
|
||
|
|
(error "Bad /proc entry on input")))))))
|
||
|
|
(send-response
|
||
|
|
status: 'ok
|
||
|
|
body: (bytevector->string
|
||
|
|
(let ((bytes (string->utf8
|
||
|
|
(string-append "Hello "
|
||
|
|
(implementation-name impl)))))
|
||
|
|
(bytevector-append
|
||
|
|
(bytevector-append
|
||
|
|
(make-tar-header-for-regular-file "proc/self/fd/1" bytes)
|
||
|
|
bytes
|
||
|
|
(make-tar-padding bytes))
|
||
|
|
(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)))
|