Migrate chez-https to jerboa-https: pure Scheme client + server, no FFI. (chez-https) -> (jerboa-https), (chez-httpd) -> (jerboa-https httpd) nested. Imports jerboa-ssl. Tests: client 20/20 pass against example.com.
ober
6c7946a1e0730b7d235654cdb0a59fc21b4098df
--- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ *.so *.o +.jerbuild-hashes --- a/Makefile +++ b/Makefile @@ -1,32 +1,39 @@ -CHEZ = scheme - -# Dependencies — clone from: -# https://github.com/ober/chez-ssl -# https://github.com/ober/chez-zlib -SSL_DIR ?= ../chez-ssl -ZLIB_DIR ?= ../chez-zlib +JERBOA_HOME ?= $(HOME)/mine/jerboa +SCHEME ?= $(JERBOA_HOME)/.chez/bin/scheme +JERBUILD ?= $(JERBOA_HOME)/jerbuild +SSL_DIR ?= ../jerboa-ssl +LIBDIRS = lib:$(SSL_DIR)/lib:$(JERBOA_HOME)/lib UNAME_S := $(shell uname -s) ifeq ($(UNAME_S),Darwin) - SO_EXT = .dylib + LD_VAR = DYLD_LIBRARY_PATH else - SO_EXT = .so + LD_VAR = LD_LIBRARY_PATH endif -LIBDIRS = src:$(SSL_DIR)/src:$(ZLIB_DIR)/src - -.PHONY: all test test-unit clean deps +.PHONY: all build transpile test test-https test-httpd clean deps -all: - @echo "chez-https is a pure Scheme library. Run 'make test' to test." +all: build -# Build chez-ssl shared object if not already built deps: - @test -f $(SSL_DIR)/chez_ssl_shim$(SO_EXT) || $(MAKE) -C $(SSL_DIR) + $(MAKE) -C $(SSL_DIR) build + +transpile: + $(JERBUILD) transpile src lib --force + +build: deps transpile + +test: test-https test-httpd + +test-https: build + JERBOA_SSL_LIB=$(SSL_DIR) \ + $(LD_VAR)=$(SSL_DIR) \ + $(SCHEME) --libdirs "$(LIBDIRS)" --script tests/https-test.ss -test: deps - @ln -sf $(realpath $(SSL_DIR))/chez_ssl_shim$(SO_EXT) ./chez_ssl_shim$(SO_EXT) - $(CHEZ) --libdirs "$(LIBDIRS)" --script tests/https-test.ss +test-httpd: build + JERBOA_SSL_LIB=$(SSL_DIR) \ + $(LD_VAR)=$(SSL_DIR) \ + $(SCHEME) --libdirs "$(LIBDIRS)" --script tests/httpd-test.ss clean: - @echo "Nothing to clean (pure Scheme library)." + rm -rf lib new file mode 100644 --- /dev/null +++ b/lib/jerboa-https.sls @@ -0,0 +1,637 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/jerboa-https.ss + +(library (jerboa-https) + (export http-get http-post http-put http-delete http-head + request-status request-text request-content request-headers + request-header request-close parse-url + flatten-request-headers build-query-string url-encode) + (import + (except (chezscheme) make-hash-table hash-table? sort sort! + printf fprintf format path-extension path-absolute? + with-input-from-string with-output-to-string iota \x31;+ + \x31;- partition make-date make-time meta atom?) + (except (jerboa prelude) string-join string-trim + string-contains string-index string-prefix?) + (jerboa-ssl)) + (def (string-prefix? prefix str) + (let ([plen (string-length prefix)] + [slen (string-length str)]) + (and (>= slen plen) + (string=? prefix (substring str 0 plen))))) + (def (string-index str ch) + (let ([len (string-length str)]) + (let loop ([i 0]) + (cond + [(= i len) #f] + [(char=? (string-ref str i) ch) i] + [else (loop (+ i 1))])))) + (def (string-contains str needle) + (let ([hlen (string-length str)] + [nlen (string-length needle)]) + (let loop ([i 0]) + (cond + [(> (+ i nlen) hlen) #f] + [(string=? needle (substring str i (+ i nlen))) i] + [else (loop (+ i 1))])))) + (def (string-trim-left str) + (let ([len (string-length str)]) + (let loop ([i 0]) + (if (and (< i len) (char-whitespace? (string-ref str i))) + (loop (+ i 1)) + (substring str i len))))) + (def (string-trim str) + (let* ([len (string-length str)] + [start (let loop ([i 0]) + (if (and (< i len) + (char-whitespace? (string-ref str i))) + (loop (+ i 1)) + i))] + [end (let loop ([i len]) + (if (and (> i start) + (char-whitespace? (string-ref str (- i 1)))) + (loop (- i 1)) + i))]) + (substring str start end))) + (def (string-join strs sep) + (if (null? strs) + "" + (let loop ([rest (cdr strs)] [acc (car strs)]) + (if (null? rest) + acc + (loop (cdr rest) (string-append acc sep (car rest))))))) + (def (string-split-crlf str) + (let ([len (string-length str)]) + (let loop ([start 0] [i 0] [acc '()]) + (cond + [(>= i len) + (reverse + (if (> i start) (cons (substring str start i) acc) acc))] + [(and (char=? (string-ref str i) #\return) + (< (+ i 1) len) + (char=? (string-ref str (+ i 1)) #\newline)) + (loop (+ i 2) (+ i 2) (cons (substring str start i) acc))] + [else (loop start (+ i 1) acc)])))) + (def (subbytevector bv start end) + (let ([result (make-bytevector (- end start))]) + (bytevector-copy! bv start result 0 (- end start)) + result)) + (def (bytevector-concat-list bvs) + (if (null? bvs) + (make-bytevector 0) + (let* ([total (fold-left + 0 (map bytevector-length bvs))] + [result (make-bytevector total)]) + (let loop ([bvs bvs] [offset 0]) + (if (null? bvs) + result + (let ([bv (car bvs)]) + (bytevector-copy! bv 0 result offset + (bytevector-length bv)) + (loop + (cdr bvs) + (+ offset (bytevector-length bv))))))))) + (def (find-crlfcrlf bv len start) + (let loop ([i start]) + (if (> (+ i 3) len) + #f + (if (and (= (bytevector-u8-ref bv i) 13) + (= (bytevector-u8-ref bv (+ i 1)) 10) + (= (bytevector-u8-ref bv (+ i 2)) 13) + (= (bytevector-u8-ref bv (+ i 3)) 10)) + i + (loop (+ i 1)))))) + (def (read-bv-line bv start len) + (let loop ([i start]) + (cond + [(>= (+ i 1) len) + (values (utf8->string (subbytevector bv start len)) len)] + [(and (= (bytevector-u8-ref bv i) 13) + (= (bytevector-u8-ref bv (+ i 1)) 10)) + (values (utf8->string (subbytevector bv start i)) (+ i 2))] + [else (loop (+ i 1))]))) + (def hex-chars "0123456789ABCDEF") + (def (url-encode str) + (let ([out (open-output-string)]) + (string-for-each + (lambda (c) + (let ([b (char->integer c)]) + (cond + [(or (and (fx>= b 65) (fx<= b 90)) + (and (fx>= b 97) (fx<= b 122)) + (and (fx>= b 48) (fx<= b 57)) + (memv c '(#\- #\_ #\. #\~))) + (write-char c out)] + [else + (let ([bv (string->utf8 (string c))]) + (do ([i 0 (+ i 1)]) + ((= i (bytevector-length bv))) + (let ([b (bytevector-u8-ref bv i)]) + (write-char #\% out) + (write-char (string-ref hex-chars (fxsrl b 4)) out) + (write-char + (string-ref hex-chars (fxand b 15)) + out))))]))) + str) + (get-output-string out))) + (def (parse-url url) + (let* ([https? (string-prefix? "https://" url)] + [http? (string-prefix? "http://" url)] + [_ (unless (or https? http?) + (error 'parse-url "unsupported URL scheme" url))] + [after-scheme (substring + url + (if https? 8 7) + (string-length url))] + [slash-pos (string-index after-scheme #\/)] + [host-port (if slash-pos + (substring after-scheme 0 slash-pos) + after-scheme)] + [path (if slash-pos + (substring + after-scheme + slash-pos + (string-length after-scheme)) + "/")] + [colon-pos (string-index host-port #\:)] + [host (if colon-pos + (substring host-port 0 colon-pos) + host-port)] + [port (if colon-pos + (string->number + (substring + host-port + (+ colon-pos 1) + (string-length host-port))) + (if https? 443 80))]) + (values host port path))) + (def (flatten-request-headers hdrs) + (if (or (not hdrs) (null? hdrs) (not (pair? hdrs))) + '() + (let loop ([items hdrs] [result '()]) + (cond + [(null? items) (reverse result)] + [(and (symbol? (car items)) (eq? (car items) '::)) + (loop (cdr items) result)] + [(pair? (car items)) + (let ([item (car items)]) + (if (and (pair? item) + (string? (car item)) + (pair? (cdr item)) + (eq? (cadr item) '::) + (pair? (cddr item))) + (loop + (cdr items) + (cons (cons (car item) (caddr item)) result)) + (loop + (cdr items) + (append + (reverse (flatten-request-headers item)) + result))))] + [else (loop (cdr items) result)])))) + (def (build-query-string params) + (if (or (not params) (null? params)) + "" + (let ([pairs (flatten-request-headers params)]) + (string-join + (map (lambda (p) + (string-append + (url-encode (car p)) + "=" + (url-encode (cdr p)))) + pairs) + "&")))) + (def (header-assoc name headers) + (let ([name-lower (string-downcase name)]) + (let loop ([h headers]) + (cond + [(null? h) #f] + [(string=? name-lower (string-downcase (caar h))) (car h)] + [else (loop (cdr h))])))) + (def (build-request method path host headers body-bv + keep-alive?) + (let ([out (open-output-string)]) + (put-string out method) + (put-string out " ") + (put-string out path) + (put-string out " HTTP/1.1\r\n") + (unless (header-assoc "Host" headers) + (put-string out "Host: ") + (put-string out host) + (put-string out "\r\n")) + (for-each + (lambda (h) + (put-string out (car h)) + (put-string out ": ") + (put-string out (cdr h)) + (put-string out "\r\n")) + headers) + (when (and body-bv + (not (header-assoc "Content-Length" headers))) + (put-string out "Content-Length: ") + (put-string + out + (number->string (bytevector-length body-bv))) + (put-string out "\r\n")) + (unless (header-assoc "Connection" headers) + (put-string + out + (if keep-alive? + "Connection: keep-alive\r\n" + "Connection: close\r\n"))) + (put-string out "\r\n") + (get-output-string out))) + (def (parse-status-line line) + (let ([space (string-index line #\space)]) + (unless space + (error 'parse-status-line "malformed status line" line)) + (let* ([rest (substring + line + (+ space 1) + (string-length line))] + [space2 (string-index rest #\space)] + [code-str (if space2 (substring rest 0 space2) rest)]) + (or (string->number code-str) + (error 'parse-status-line + "invalid status code" + code-str))))) + (def (parse-headers lines) + (let loop ([lines lines] [acc '()]) + (if (null? lines) + (reverse acc) + (let* ([line (car lines)] [colon (string-index line #\:)]) + (if colon + (loop + (cdr lines) + (cons + (cons + (string-downcase (substring line 0 colon)) + (string-trim-left + (substring + line + (+ colon 1) + (string-length line)))) + acc)) + (loop (cdr lines) acc)))))) + (def (header-value headers name) + (let ([pair (assoc name headers)]) (and pair (cdr pair)))) + (def (chunked-encoding? headers) + (let ([te (header-value headers "transfer-encoding")]) + (and te + (string-contains (string-downcase te) "chunked") + #t))) + (def (decode-chunked bv) + (let ([len (bytevector-length bv)]) + (let loop ([pos 0] [chunks '()]) + (if (>= pos len) + (bytevector-concat-list (reverse chunks)) + (let-values ([(size-str next-pos) + (read-bv-line bv pos len)]) + (let* ([semi (string-index size-str #\;)] + [hex-str (string-trim + (if semi + (substring size-str 0 semi) + size-str))] + [chunk-size (string->number hex-str 16)]) + (cond + [(or (not chunk-size) (= chunk-size 0)) + (bytevector-concat-list (reverse chunks))] + [(> (+ next-pos chunk-size) len) + (bytevector-concat-list + (reverse + (cons (subbytevector bv next-pos len) chunks)))] + [else + (loop + (+ next-pos chunk-size 2) + (cons + (subbytevector + bv + next-pos + (+ next-pos chunk-size)) + chunks))]))))))) + (def *ssl-initialized* #f) + (def (ensure-ssl-init!) + (unless *ssl-initialized* + (ssl-init!) + (set! *ssl-initialized* #t))) + (def *conn-pool* (make-hashtable string-hash string=?)) + (def *conn-pool-mutex* (make-mutex 'conn-pool)) + (def (pool-key host port) + (string-append host ":" (number->string port))) + (def (pool-get host port) + (let ([key (pool-key host port)]) + (with-mutex *conn-pool-mutex* + (let ([conns (hashtable-ref *conn-pool* key '())]) + (if (null? conns) + #f + (let ([conn (car conns)]) + (hashtable-set! *conn-pool* key (cdr conns)) + conn)))))) + (def (pool-put host port conn) + (let ([key (pool-key host port)]) + (with-mutex *conn-pool-mutex* + (let ([conns (hashtable-ref *conn-pool* key '())]) + (if (< (length conns) 4) + (hashtable-set! *conn-pool* key (cons conn conns)) + (guard (e [#t (void)]) (ssl-close conn))))))) + (def (ssl-read-bytes conn n) + (let ([result (make-bytevector n)] + [buf (make-bytevector (min n 32768))]) + (let loop ([offset 0]) + (if (= offset n) + result + (let* ([want (min (- n offset) (bytevector-length buf))] + [got (ssl-read conn buf want)]) + (if (<= got 0) + (subbytevector result 0 offset) + (begin + (bytevector-copy! buf 0 result offset got) + (loop (+ offset got))))))))) + (def (ssl-read-until-eof conn) + (let ([buf (make-bytevector 32768)]) + (let loop ([chunks '()]) + (let ([n (ssl-read conn buf 32768)]) + (if (<= n 0) + (bytevector-concat-list (reverse chunks)) + (loop (cons (subbytevector buf 0 n) chunks))))))) + (def (ssl-read-headers conn) + (let ([buf (make-bytevector 8192)]) + (let loop ([chunks '()] [total 0]) + (let ([n (ssl-read conn buf 8192)]) + (if (<= n 0) + (values + (bytevector-concat-list (reverse chunks)) + (make-bytevector 0)) + (let* ([chunk (subbytevector buf 0 n)] + [all-chunks (reverse (cons chunk chunks))] + [raw (bytevector-concat-list all-chunks)] + [raw-len (bytevector-length raw)] + [sep (find-crlfcrlf raw raw-len 0)]) + (if sep + (let ([header-end (+ sep 4)]) + (values + (subbytevector raw 0 header-end) + (if (< header-end raw-len) + (subbytevector raw header-end raw-len) + (make-bytevector 0)))) + (loop (list raw) raw-len)))))))) + (def (ssl-read-chunked conn initial-bytes) + (let ([buf (make-bytevector 32768)]) + (let loop ([chunks (if (> (bytevector-length initial-bytes) + 0) + (list initial-bytes) + '())] + [raw-so-far initial-bytes]) + (let* ([combined (bytevector-concat-list (reverse chunks))] + [combined-len (bytevector-length combined)]) + (if (find-zero-chunk combined combined-len) + (decode-chunked combined) + (let ([n (ssl-read conn buf 32768)]) + (if (<= n 0) + (decode-chunked combined) + (loop + (list + (bytevector-concat-list + (list combined (subbytevector buf 0 n)))) + combined)))))))) + (def (find-zero-chunk bv len) + (let loop ([pos 0]) + (if (>= pos len) + #f + (let lscan ([i pos]) + (cond + [(>= (+ i 1) len) #f] + [(and (= (bytevector-u8-ref bv i) 13) + (= (bytevector-u8-ref bv (+ i 1)) 10)) + (if (and (= (- i pos) 1) + (= (bytevector-u8-ref bv pos) 48)) + #t + (let ([hex-str (utf8->string + (subbytevector bv pos i))]) + (let ([semi (string-index hex-str #\;)]) + (let* ([clean (string-trim + (if semi + (substring hex-str 0 semi) + hex-str))] + [chunk-size (string->number clean 16)]) + (if (or (not chunk-size) (= chunk-size 0)) + #t + (let ([next (+ i 2 chunk-size 2)]) + (if (> next len) #f (loop next))))))))] + [else (lscan (+ i 1))]))))) + (def (read-response conn) + (let-values ([(header-raw extra-bytes) + (ssl-read-headers conn)]) + (let* ([header-len (bytevector-length header-raw)] + [header-str (if (> header-len 4) + (utf8->string + (subbytevector + header-raw + 0 + (- header-len 4))) + (error 'read-response + "malformed response: no headers"))] + [lines (string-split-crlf header-str)]) + (when (null? lines) + (error 'read-response "empty HTTP response")) + (let ([status (parse-status-line (car lines))] + [headers (parse-headers (cdr lines))]) + (if (= status 100) + (read-response-after-100 conn extra-bytes) + (let* ([cl-str (header-value headers "content-length")] + [content-length (and cl-str + (string->number cl-str))] + [chunked? (chunked-encoding? headers)] + [conn-hdr (header-value headers "connection")] + [keep-alive? (not (and conn-hdr + (string-contains + (string-downcase conn-hdr) + "close")))] + [body (cond + [chunked? + (ssl-read-chunked conn extra-bytes)] + [content-length + (read-content-length-body + conn + extra-bytes + content-length)] + [(not keep-alive?) + (let ([rest (ssl-read-until-eof conn)]) + (bytevector-concat-list + (list extra-bytes rest)))] + [else extra-bytes])]) + (values status headers body keep-alive?))))))) + (def (read-content-length-body + conn + extra-bytes + content-length) + (let ([extra-len (bytevector-length extra-bytes)]) + (cond + [(>= extra-len content-length) + (subbytevector extra-bytes 0 content-length)] + [(= extra-len 0) (ssl-read-bytes conn content-length)] + [else + (let ([remaining (ssl-read-bytes + conn + (- content-length extra-len))]) + (bytevector-concat-list (list extra-bytes remaining)))]))) + (def (read-response-after-100 conn extra-bytes) + (let ([extra-len (bytevector-length extra-bytes)]) + (if (> extra-len 0) + (let ([sep (find-crlfcrlf extra-bytes extra-len 0)]) + (if sep + (let* ([header-end (+ sep 4)] + [header-raw (subbytevector + extra-bytes + 0 + header-end)] + [body-extra (if (< header-end extra-len) + (subbytevector + extra-bytes + header-end + extra-len) + (make-bytevector 0))]) + (parse-response-from-header-raw + conn + header-raw + body-extra)) + (read-response conn))) + (read-response conn)))) + (def (parse-response-from-header-raw + conn + header-raw + extra-bytes) + (let* ([header-len (bytevector-length header-raw)] + [header-str (utf8->string + (subbytevector header-raw 0 (- header-len 4)))] + [lines (string-split-crlf header-str)] + [status (parse-status-line (car lines))] + [headers (parse-headers (cdr lines))] + [cl-str (header-value headers "content-length")] + [content-length (and cl-str (string->number cl-str))] + [chunked? (chunked-encoding? headers)] + [conn-hdr (header-value headers "connection")] + [keep-alive? (not (and conn-hdr + (string-contains + (string-downcase conn-hdr) + "close")))] + [body (cond + [chunked? (ssl-read-chunked conn extra-bytes)] + [content-length + (read-content-length-body + conn + extra-bytes + content-length)] + [(not keep-alive?) + (let ([rest (ssl-read-until-eof conn)]) + (bytevector-concat-list (list extra-bytes rest)))] + [else extra-bytes])]) + (values status headers body keep-alive?))) + (def (make-request-result status headers body-bv) + (vector status headers body-bv)) + (def (request-status req) (vector-ref req 0)) + (def (request-headers req) (vector-ref req 1)) + (def (request-content req) (vector-ref req 2)) + (def (request-text req) + (let ([body (vector-ref req 2)]) + (if (= (bytevector-length body) 0) "" (utf8->string body)))) + (def (request-header req name) + (let ([pair (assoc + (string-downcase name) + (vector-ref req 1))]) + (and pair (cdr pair)))) + (def (request-close req) (void)) + (def (parse-keyword-args args) + (let loop ([args args] [headers '()] [params #f] [data #f]) + (if (null? args) + (values headers params data) + (if (null? (cdr args)) + (error 'http-request + "missing value for keyword" + (car args)) + (let ([key (car args)] [val (cadr args)]) + (cond + [(eq? key 'headers:) + (loop (cddr args) val params data)] + [(eq? key 'params:) + (loop (cddr args) headers val data)] + [(eq? key 'data:) + (loop (cddr args) headers params val)] + [else + (error 'http-request "unknown keyword" key)])))))) + (def (do-request method url headers params data) + (ensure-ssl-init!) + (let-values ([(host port path) (parse-url url)]) + (let* ([query (build-query-string params)] + [full-path (cond + [(string=? query "") path] + [(string-contains path "?") + (string-append path "&" query)] + [else (string-append path "?" query)])] + [flat-headers (flatten-request-headers headers)] + [body-bv (cond + [(not data) #f] + [(bytevector? data) data] + [(string? data) (string->utf8 data)] + [else + (error 'do-request + "unsupported body type" + data)])] + [pooled-conn (pool-get host port)] + [conn (or pooled-conn (ssl-connect host port))] + [using-pooled? (and pooled-conn #t)] + [request-str (build-request method full-path host + flat-headers body-bv #t)]) + (guard (e + [#t + (when using-pooled? + (guard (e2 [#t (void)]) (ssl-close conn))) + (if using-pooled? + (do-request-fresh method host port full-path + flat-headers body-bv) + (begin + (guard (e2 [#t (void)]) (ssl-close conn)) + (raise e)))]) + (ssl-write-string conn request-str) + (when body-bv (ssl-write conn body-bv)) + (let-values ([(status resp-headers body keep-alive?) + (read-response conn)]) + (if keep-alive? + (pool-put host port conn) + (guard (e [#t (void)]) (ssl-close conn))) + (make-request-result status resp-headers body)))))) + (def (do-request-fresh method host port full-path + flat-headers body-bv) + (let* ([conn (ssl-connect host port)] + [request-str (build-request method full-path host + flat-headers body-bv #t)]) + (guard (e + [#t (guard (e2 [#t (void)]) (ssl-close conn)) (raise e)]) + (ssl-write-string conn request-str) + (when body-bv (ssl-write conn body-bv)) + (let-values ([(status resp-headers body keep-alive?) + (read-response conn)]) + (if keep-alive? + (pool-put host port conn) + (guard (e [#t (void)]) (ssl-close conn))) + (make-request-result status resp-headers body))))) + (def (http-get url . args) + (let-values ([(headers params data) + (parse-keyword-args args)]) + (do-request "GET" url headers params #f))) + (def (http-post url . args) + (let-values ([(headers params data) + (parse-keyword-args args)]) + (do-request "POST" url headers params data))) + (def (http-put url . args) + (let-values ([(headers params data) + (parse-keyword-args args)]) + (do-request "PUT" url headers params data))) + (def (http-delete url . args) + (let-values ([(headers params data) + (parse-keyword-args args)]) + (do-request "DELETE" url headers params #f))) + (def (http-head url . args) + (let-values ([(headers params data) + (parse-keyword-args args)]) + (do-request "HEAD" url headers params #f)))) new file mode 100644 --- /dev/null +++ b/lib/jerboa-https/httpd.sls @@ -0,0 +1,711 @@ +#!chezscheme +;;; Generated by jerbuild — DO NOT EDIT +;;; Source: src/jerboa-https/httpd.ss + +(library (jerboa-https httpd) + (export httpd-start httpd-stop httpd-start-https httpd-route + httpd-route-prefix httpd-route-static make-router + router-add! router-add-prefix! router-lookup http-req-method + http-req-path http-req-query http-req-headers + http-req-header http-req-body http-req-client-addr + http-req-version http-respond http-respond-html + http-respond-json http-respond-file http-respond-error + http-respond-redirect http-respond-chunk-begin + http-respond-chunk http-respond-chunk-end httpd-config) + (import + (except (chezscheme) make-hash-table hash-table? sort sort! + printf fprintf format path-extension path-absolute? + with-input-from-string with-output-to-string iota \x31;+ + \x31;- partition make-date make-time meta atom?) + (except + (jerboa prelude) + string-trim + string-prefix? + string-index) + (jerboa-ssl)) + (def *config* (vector 4 8192 32768 60 120 1048576 128)) + (def (cfg-ref i) (vector-ref *config* i)) + (def (httpd-config . args) + (let loop ([args args]) + (unless (null? args) + (let ([key (car args)] [val (cadr args)]) + (cond + [(eq? key 'workers:) (vector-set! *config* 0 val)] + [(eq? key 'input-buffer:) (vector-set! *config* 1 val)] + [(eq? key 'output-buffer:) (vector-set! *config* 2 val)] + [(eq? key 'max-body:) (vector-set! *config* 5 val)] + [(eq? key 'backlog:) (vector-set! *config* 6 val)]) + (loop (cddr args)))))) + (def (string-index str ch) + (let ([len (string-length str)]) + (let loop ([i 0]) + (cond + [(= i len) #f] + [(char=? (string-ref str i) ch) i] + [else (loop (+ i 1))])))) + (def (string-prefix? prefix str) + (let ([plen (string-length prefix)] + [slen (string-length str)]) + (and (>= slen plen) + (string=? prefix (substring str 0 plen))))) + (def (string-trim-left str) + (let ([len (string-length str)]) + (let loop ([i 0]) + (if (and (< i len) (char-whitespace? (string-ref str i))) + (loop (+ i 1)) + (substring str i len))))) + (def *input-pool* '()) + (def *input-pool-mutex* (make-mutex 'httpd-input-pool)) + (def *output-pool* '()) + (def *output-pool-mutex* (make-mutex 'httpd-output-pool)) + (def (pool-get! pool-var mutex-var size) + (with-mutex mutex-var + (let ([pool (pool-var)]) + (if (null? pool) + (make-bytevector size) + (let ([buf (car pool)]) (pool-var (cdr pool)) buf))))) + (def (pool-put! pool-var mutex-var buf) + (with-mutex mutex-var (pool-var (cons buf (pool-var))))) + (define-syntax get-input-buffer + (syntax-rules () + [(_) + (with-mutex *input-pool-mutex* + (if (null? *input-pool*) + (make-bytevector (cfg-ref 1)) + (let ([buf (car *input-pool*)]) + (set! *input-pool* (cdr *input-pool*)) + buf)))])) + (define-syntax put-input-buffer! + (syntax-rules () + [(_ buf) + (with-mutex *input-pool-mutex* + (set! *input-pool* (cons buf *input-pool*)))])) + (define-syntax get-output-buffer + (syntax-rules () + [(_) + (with-mutex *output-pool-mutex* + (if (null? *output-pool*) + (make-bytevector (cfg-ref 2)) + (let ([buf (car *output-pool*)]) + (set! *output-pool* (cdr *output-pool*)) + buf)))])) + (define-syntax put-output-buffer! + (syntax-rules () + [(_ buf) + (with-mutex *output-pool-mutex* + (set! *output-pool* (cons buf *output-pool*)))])) + (def (make-reader conn buf) (vector conn buf 0 0)) + (def (reader-conn r) (vector-ref r 0)) + (def (reader-buf r) (vector-ref r 1)) + (def (reader-pos r) (vector-ref r 2)) + (def (reader-end r) (vector-ref r 3)) + (def (reader-pos-set! r v) (vector-set! r 2 v)) + (def (reader-end-set! r v) (vector-set! r 3 v)) + (def (reader-available r) (- (reader-end r) (reader-pos r))) + (def (reader-compact! r) + (let ([pos (reader-pos r)] + [end (reader-end r)] + [buf (reader-buf r)]) + (when (> pos 0) + (let ([avail (- end pos)]) + (bytevector-copy! buf pos buf 0 avail) + (reader-pos-set! r 0) + (reader-end-set! r avail))))) + (def (reader-fill! r) + (reader-compact! r) + (let* ([buf (reader-buf r)] + [end (reader-end r)] + [cap (bytevector-length buf)] + [space (- cap end)]) + (if (<= space 0) + #t + (let ([n (conn-read (reader-conn r) buf end)]) #f)))) + (def *temp-read-buf* #f) + (def *temp-read-mutex* (make-mutex 'temp-read)) + (def (reader-fill-from-conn! r) + (reader-compact! r) + (let* ([buf (reader-buf r)] + [end (reader-end r)] + [cap (bytevector-length buf)] + [space (- cap end)]) + (when (<= space 0) (error 'reader-fill! "buffer overflow")) + (let ([tmp (make-bytevector space)]) + (let ([n (conn-read (reader-conn r) tmp space)]) + (when (> n 0) + (bytevector-copy! tmp 0 buf end n) + (reader-end-set! r (+ end n))) + n)))) + (def (reader-read-byte r) + (when (= (reader-pos r) (reader-end r)) + (let ([n (reader-fill-from-conn! r)]) + (when (<= n 0) (set! n 0)))) + (if (= (reader-pos r) (reader-end r)) + #f + (let ([b (bytevector-u8-ref (reader-buf r) (reader-pos r))]) + (reader-pos-set! r (+ (reader-pos r) 1)) + b))) + (def (reader-read-line r) + (let loop ([acc #f]) + (let ([pos (reader-pos r)] [end (reader-end r)]) + (if (= pos end) + (let ([n (reader-fill-from-conn! r)]) + (if (<= n 0) acc (loop acc))) + (let scan ([i pos]) + (cond + [(>= i (- end 1)) + (let* ([chunk-len (- end pos)] + [chunk-bv (make-bytevector chunk-len)]) + (bytevector-copy! (reader-buf r) pos chunk-bv 0 + chunk-len) + (reader-pos-set! r end) + (let ([chunk-str (utf8->string chunk-bv)] + [n (reader-fill-from-conn! r)]) + (let ([new-acc (if acc + (string-append acc chunk-str) + chunk-str)]) + (if (<= n 0) + (if (= (string-length new-acc) 0) #f new-acc) + (loop new-acc)))))] + [(and (= (bytevector-u8-ref (reader-buf r) i) 13) + (= (bytevector-u8-ref (reader-buf r) (+ i 1)) 10)) + (let* ([line-len (- i pos)] + [line-bv (make-bytevector line-len)]) + (bytevector-copy! (reader-buf r) pos line-bv 0 + line-len) + (reader-pos-set! r (+ i 2)) + (let ([chunk-str (utf8->string line-bv)]) + (if acc (string-append acc chunk-str) chunk-str)))] + [else (scan (+ i 1))])))))) + (def (reader-read-bytes r n) + (let ([result (make-bytevector n)]) + (let loop ([offset 0]) + (if (= offset n) + result + (let ([avail (reader-available r)]) + (if (> avail 0) + (let ([take (min avail (- n offset))]) + (bytevector-copy! (reader-buf r) (reader-pos r) + result offset take) + (reader-pos-set! r (+ (reader-pos r) take)) + (loop (+ offset take))) + (let ([rc (reader-fill-from-conn! r)]) + (if (<= rc 0) #f (loop offset))))))))) + (def (make-writer conn buf) (vector conn buf 0)) + (def (writer-conn w) (vector-ref w 0)) + (def (writer-buf w) (vector-ref w 1)) + (def (writer-pos w) (vector-ref w 2)) + (def (writer-pos-set! w v) (vector-set! w 2 v)) + (def (writer-flush! w) + (let ([pos (writer-pos w)]) + (when (> pos 0) + (let ([bv (make-bytevector pos)]) + (bytevector-copy! (writer-buf w) 0 bv 0 pos) + (conn-write (writer-conn w) bv) + (writer-pos-set! w 0))))) + (def (writer-write-byte! w b) + (let ([pos (writer-pos w)] [buf (writer-buf w)]) + (when (= pos (bytevector-length buf)) + (writer-flush! w) + (set! pos 0)) + (bytevector-u8-set! buf pos b) + (writer-pos-set! w (+ pos 1)))) + (def (writer-write-bv! w bv) + (let ([len (bytevector-length bv)] + [pos (writer-pos w)] + [buf (writer-buf w)] + [cap (bytevector-length (writer-buf w))]) + (if (<= (+ pos len) cap) + (begin + (bytevector-copy! bv 0 buf pos len) + (writer-pos-set! w (+ pos len))) + (begin + (writer-flush! w) + (if (> len cap) + (conn-write (writer-conn w) bv) + (begin + (bytevector-copy! bv 0 buf 0 len) + (writer-pos-set! w len))))))) + (def (writer-write-string! w str) + (writer-write-bv! w (string->utf8 str))) + (def cr-lf (string->utf8 "\r\n")) + (def (writer-write-crlf! w) (writer-write-bv! w cr-lf)) + (def (make-http-request method path query version headers + body client-addr) + (vector method path query version headers body client-addr)) + (def (http-req-method r) (vector-ref r 0)) + (def (http-req-path r) (vector-ref r 1)) + (def (http-req-query r) (vector-ref r 2)) + (def (http-req-version r) (vector-ref r 3)) + (def (http-req-headers r) (vector-ref r 4)) + (def (http-req-body r) (vector-ref r 5)) + (def (http-req-client-addr r) (vector-ref r 6)) + (def (http-req-header r name) + (let ([pair (assoc + (string-downcase name) + (vector-ref r 4))]) + (and pair (cdr pair)))) + (def (parse-request-line line) + (let* ([sp1 (string-index line #\space)] + [method (substring line 0 sp1)] + [rest (substring line (+ sp1 1) (string-length line))] + [sp2 (string-index rest #\space)] + [target (substring rest 0 sp2)] + [version (substring rest (+ sp2 1) (string-length rest))] + [qmark (string-index target #\?)] + [path (if qmark (substring target 0 qmark) target)] + [query (if qmark + (substring + target + (+ qmark 1) + (string-length target)) + #f)]) + (values method path query version))) + (def (read-request reader client-addr) + (let ([request-line (reader-read-line reader)]) + (if (not request-line) + #f + (let-values ([(method path query version) + (parse-request-line request-line)]) + (let ([headers (read-headers reader)]) + (let ([body (read-request-body reader headers)]) + (make-http-request method path query version headers + body client-addr))))))) + (def (read-headers reader) + (let loop ([acc '()]) + (let ([line (reader-read-line reader)]) + (cond + [(not line) (reverse acc)] + [(string=? line "") (reverse acc)] + [else + (let ([colon (string-index line #\:)]) + (if colon + (loop + (cons + (cons + (string-downcase (substring line 0 colon)) + (string-trim-left + (substring + line + (+ colon 1) + (string-length line)))) + acc)) + (loop acc)))]))))