Initial commit
This commit is contained in:
commit
7bcd912672
|
|
@ -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)))
|
||||
|
|
@ -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)
|
||||
Loading…
Reference in New Issue