eval-server/eval-server.sld

(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)))