Refactor a lot for csm, read tar from request
https://wiki.call-cc.org/eggref/5/csm
This commit is contained in:
parent
f659ac07cd
commit
c93b9b7486
|
|
@ -0,0 +1,5 @@
|
|||
*.import.scm
|
||||
*.o
|
||||
*.so
|
||||
/eval-client
|
||||
/eval-server
|
||||
|
|
@ -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))))))
|
||||
|
|
@ -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))))))))
|
||||
132
eval-server.scm
132
eval-server.scm
|
|
@ -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)
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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
|
||||
|
|
@ -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)))))
|
||||
Loading…
Reference in New Issue