From c93b9b7486ecc63522d4a9e719ae3c1ca7d3359e Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Sun, 19 Sep 2021 21:44:34 +0300 Subject: [PATCH] Refactor a lot for csm, read tar from request https://wiki.call-cc.org/eggref/5/csm --- .gitignore | 5 ++ eval-client.scm | 67 ----------------------- eval-client.sld | 26 +++++++++ eval-server.scm | 132 --------------------------------------------- eval-server.sld | 99 ++++++++++++++++++++++++++++++++++ tar.import.scm | 57 ++++++++++++++++++++ tar.sld | 139 ++++++++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 326 insertions(+), 199 deletions(-) create mode 100644 .gitignore delete mode 100644 eval-client.scm create mode 100644 eval-client.sld delete mode 100644 eval-server.scm create mode 100644 eval-server.sld create mode 100644 tar.import.scm create mode 100644 tar.sld diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..9bd489e --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +*.import.scm +*.o +*.so +/eval-client +/eval-server diff --git a/eval-client.scm b/eval-client.scm deleted file mode 100644 index 5ecf5cb..0000000 --- a/eval-client.scm +++ /dev/null @@ -1,67 +0,0 @@ -(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) - (write-string (utf8->string (read-tar-entry-bytes entry))) - (newline) - (loop)))))) diff --git a/eval-client.sld b/eval-client.sld new file mode 100644 index 0000000..2a42938 --- /dev/null +++ b/eval-client.sld @@ -0,0 +1,26 @@ +(define-library (eval-client) + (import (srfi 1) + (srfi 98) + (scheme base) + (scheme write) + (uri-common) + (only (intarweb) headers make-request) + (http-client) + (tar)) + (begin + + (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) + (write-string (utf8->string (read-tar-entry-bytes entry))) + (newline) + (loop)))))))) diff --git a/eval-server.scm b/eval-server.scm deleted file mode 100644 index 153ea85..0000000 --- a/eval-server.scm +++ /dev/null @@ -1,132 +0,0 @@ -(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 implementation-name first) - -(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 "") - (make-bytevector 12 0))) - (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 - (string-append "Hello " (implementation-name impl))))) - (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) diff --git a/eval-server.sld b/eval-server.sld new file mode 100644 index 0000000..cf9f0e0 --- /dev/null +++ b/eval-server.sld @@ -0,0 +1,99 @@ +(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))) diff --git a/tar.import.scm b/tar.import.scm new file mode 100644 index 0000000..b9820c1 --- /dev/null +++ b/tar.import.scm @@ -0,0 +1,57 @@ +;;;; tar.import.scm - GENERATED BY CHICKEN 5.2.1 -*- Scheme -*- + +(##sys#with-environment + (lambda () + (scheme#eval + '(import-syntax + (only r7rs + begin + cond-expand + export + import + import-for-syntax + include + include-ci + syntax-rules) + scheme.base)) + (import + (only r7rs + begin + cond-expand + export + import + import-for-syntax + include + include-ci + syntax-rules)) + (##sys#register-compiled-module + 'tar + 'tar + (scheme#list + '(tar-entry-octal-ref . tar#tar-entry-octal-ref) + '(tar-octal . tar#tar-octal) + '(tar-entry-string-ref . tar#tar-entry-string-ref) + '(tar-string . tar#tar-string) + '(tar-limit-exceeded . tar#tar-limit-exceeded) + '(read-exactly-n-bytes . tar#read-exactly-n-bytes) + '(bytevector-every? . tar#bytevector-every?) + '(bytevector-fold . tar#bytevector-fold) + '(align . tar#align)) + '((tar-content-type . tar#tar-content-type) + (tar-content-type? . tar#tar-content-type?) + (tar-entry-name . tar#tar-entry-name) + (tar-entry-size . tar#tar-entry-size) + (read-tar-entry . tar#read-tar-entry) + (read-tar-entry-bytes . tar#read-tar-entry-bytes) + (make-tar-padding . tar#make-tar-padding) + (make-tar-eof . tar#make-tar-eof) + (make-tar-header-for-regular-file + . + tar#make-tar-header-for-regular-file)) + (scheme#list + (scheme#cons + '|\x04r7rstar| + (##sys#er-transformer (##core#lambda (x r c) (##core#undefined))))) + (scheme#list)))) + +;; END OF FILE diff --git a/tar.sld b/tar.sld new file mode 100644 index 0000000..9cd5b62 --- /dev/null +++ b/tar.sld @@ -0,0 +1,139 @@ +(define-library (tar) + (export tar-content-type + tar-content-type? + tar-entry-name + tar-entry-size + read-tar-entry + read-tar-entry-bytes + make-tar-padding + make-tar-eof + make-tar-header-for-regular-file) + (import (scheme base)) + (begin + + (define (align multiple value) + (truncate-remainder (- multiple (truncate-remainder value multiple)) + multiple)) + + (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 (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-exactly-n-bytes n) + (let ((bytes (read-bytevector n))) + (if (= n (bytevector-length bytes)) bytes (error "Short read")))) + + ;; + + (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-entry-string-ref entry offset len) + (let ((limit (let loop ((limit (+ offset len))) + (cond ((<= limit offset) + offset) + ((zero? (bytevector-u8-ref entry (- limit 1))) + (loop (- limit 1))) + (else + limit))))) + (if (= limit (+ offset len)) + (error "tar: string is not null terminated") + (utf8->string (bytevector-copy entry offset limit))))) + + (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 (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 (tar-entry-name entry) + (tar-entry-string-ref entry 0 100)) + + (define (tar-entry-size entry) + (tar-entry-octal-ref entry 124 12)) + + (define (read-tar-entry) + (let ((entry (read-exactly-n-bytes 512))) + (if (bytevector-every? zero? entry) (eof-object) entry))) + + (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)) + + (define (make-tar-padding bytes) + (make-bytevector (align 512 (bytevector-length bytes)) 0)) + + (define (make-tar-eof) + (make-bytevector (* 512 2) 0)) + + (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 "") + (make-bytevector 12 0))) + (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)))))