commit 7bcd9126726b174036c6217ec97439c1b629807a Author: Lassi Kortela Date: Sun Sep 19 14:31:59 2021 +0300 Initial commit diff --git a/eval-client.scm b/eval-client.scm new file mode 100644 index 0000000..b614ec8 --- /dev/null +++ b/eval-client.scm @@ -0,0 +1,68 @@ +(import (srfi 1) + (srfi 98) + (scheme base) + (scheme write) + (http-client) + (intarweb) + (uri-common)) + +(define tar-content-type "application/x-tar") + +(define (read-exactly-n-bytes n) + (let ((bytes (read-bytevector n))) + (if (= n (bytevector-length bytes)) bytes (error "Short read")))) + +(define (tar-entry-octal-ref entry offset len) + (let loop ((offset offset) (len len) (value 0)) + (if (<= len 0) value + (let ((dig0 (char->integer #\0)) + (dig7 (char->integer #\7)) + (byte (bytevector-u8-ref entry offset))) + (loop (+ offset 1) (- len 1) + (if (<= dig0 byte dig7) + (let ((digit (- byte dig0))) + (+ digit (* value 8))) + value)))))) + +(define (make-tar-eof) + (make-bytevector (* 512 2) 0)) + +(define (tar-entry-size entry) + (tar-entry-octal-ref entry 124 12)) + +(define (bytevector-every? f bytes) + (let loop ((i 0)) + (or (= i (bytevector-length bytes)) + (and (f (bytevector-u8-ref bytes i)) + (loop (+ i 1)))))) + +(define (read-tar-entry) + (let ((entry (read-exactly-n-bytes 512))) + (if (bytevector-every? zero? entry) (eof-object) entry))) + +(define (align multiple value) + (truncate-remainder (- multiple (truncate-remainder value multiple)) + multiple)) + +(define (read-tar-entry-bytes entry) + (let* ((nbyte (tar-entry-size entry)) + (bytes (read-exactly-n-bytes nbyte)) + (nulls (read-exactly-n-bytes (align 512 nbyte)))) + bytes)) + +(with-input-from-request + (make-request + method: 'POST + uri: (uri-reference "http://localhost:3000/gauche") + headers: (headers `((content-type ,tar-content-type) + (accept ,tar-content-type)))) + (lambda () + (write-string (utf8->string (make-tar-eof)))) + (lambda () + (let loop () + (let ((entry (read-tar-entry))) + (unless (eof-object? entry) + (read-tar-entry-bytes entry) + (loop)))) + (display "Success") + (newline))) diff --git a/eval-server.scm b/eval-server.scm new file mode 100644 index 0000000..208b490 --- /dev/null +++ b/eval-server.scm @@ -0,0 +1,128 @@ +(import (srfi 1) + (srfi 98) + (scheme base) + (scheme write) + (only (chicken blob) blob->string) + (only (srfi 4) u8vector->blob) + (spiffy) + (intarweb) + (uri-common)) + +(define implementations + '(("gauche" '("gosh" "-r" "7")))) + +(define tar-content-type "application/x-tar") + +(define (tar-content-type? symbol) + (eq? symbol (string->symbol tar-content-type))) + +(define (tar-limit-exceeded) + (error "tar limit exceeded")) + +(define (tar-string nbytes str) + (let* ((bytes (string->utf8 str)) + (room (- nbytes (bytevector-length bytes)))) + (if (> room 0) + (bytevector-append bytes (make-bytevector room 0)) + (tar-limit-exceeded)))) + +(define (tar-octal nbytes value) + (let* ((bytes (string->utf8 (number->string value 8))) + (room (- nbytes (bytevector-length bytes)))) + (if (> room 0) + (bytevector-append (make-bytevector (- room 1) (char->integer #\0)) + bytes (bytevector 0)) + (tar-limit-exceeded)))) + +(define (bytevector-fold merge state bytes) + (let loop ((state state) (i 0)) + (if (= i (bytevector-length bytes)) state + (loop (merge (bytevector-u8-ref bytes i) state) (+ i 1))))) + +(define (make-tar-header-for-regular-file filename bytes) + (let* ((before-checksum + (bytevector-append + (tar-string 100 filename) + (tar-octal 8 #x444) + (tar-octal 8 0) + (tar-octal 8 0) + (tar-octal 12 (bytevector-length bytes)) + (tar-octal 12 0))) + (after-checksum + (bytevector-append + (bytevector (char->integer #\space)) + (bytevector (char->integer #\0)) + (tar-string 100 "") + (tar-string 6 "ustar") + (string->utf8 "00") + (tar-string 32 "root") + (tar-string 32 "root") + (tar-octal 8 0) + (tar-octal 8 0) + (tar-string 155 ""))) + (blank-checksum + (make-bytevector 7 (char->integer #\space))) + (checksum + (truncate-remainder (+ (bytevector-fold + 0 before-checksum) + (bytevector-fold + 0 blank-checksum) + (bytevector-fold + 0 after-checksum)) + (expt 8 6)))) + (bytevector-append before-checksum + (tar-octal 7 checksum) + after-checksum))) + +(define (align multiple value) + (truncate-remainder (- multiple (truncate-remainder value multiple)) + multiple)) + +(define (make-tar-padding bytes) + (make-bytevector (align 512 (bytevector-length bytes)) 0)) + +(define (make-tar-eof) + (make-bytevector (* 512 2) 0)) + +(define (respond-with-error status string) + (send-response status: status body: string)) + +(define (bytevector->string bytes) + (blob->string (u8vector->blob bytes))) + +(define (handle-the-scheme-implementation impl) + (send-response + status: 'ok + body: (bytevector->string + (let ((bytes (string->utf8 "Hello world"))) + (bytevector-append + (bytevector-append + (make-tar-header-for-regular-file "proc/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)))) + +(vhost-map `(("localhost" . ,handle-request))) +(server-port + (string->number (or (get-environment-variable "PORT") (error "No PORT")))) +(start-server)