Add Gerbil Sinatra compatibility support
ober
6531120a5fb4a1f6816eb28774f99d42931d37be
new file mode 100644 --- /dev/null +++ b/lib/std/crypto.ss @@ -0,0 +1,10 @@ +#!chezscheme +;;; :std/crypto -- commonly used crypto facade + +(library (std crypto) + (export + hmac hmac-md5 hmac-sha1 hmac-sha256 hmac-sha384 hmac-sha512 + random-bytes random-bytes! + random-u64 random-token random-uuid) + (import (std crypto hmac) + (std crypto random))) --- a/lib/std/crypto/hmac.ss +++ b/lib/std/crypto/hmac.ss @@ -1,9 +1,72 @@ #!chezscheme -;;; :std/crypto/hmac -- HMAC message authentication (wraps jerboa-crypto) +;;; :std/crypto/hmac -- HMAC message authentication (library (std crypto hmac) (export hmac hmac-md5 hmac-sha1 hmac-sha256 hmac-sha384 hmac-sha512) - (import (only (jerboa-crypto) hmac hmac-md5 hmac-sha1 hmac-sha256 hmac-sha384 hmac-sha512)) + (import (except (chezscheme) sha256-bytevector) + (std crypto sha256-pure) + (only (jerboa core) def)) + + (def (hmac algorithm key data) + (case algorithm + [(sha256 hmac-sha256) (hmac-sha256 key data)] + [else (error 'hmac "unsupported HMAC algorithm" algorithm)])) + + (def (hmac-sha256 key data) + (let* ([key-bv (->bytevector key)] + [data-bv (->bytevector data)] + [key-bv (if (> (bytevector-length key-bv) 64) + (sha256-bytevector key-bv) + key-bv)] + [key-block (zero-pad key-bv 64)] + [ipad (xor-pad key-block #x36)] + [opad (xor-pad key-block #x5c)]) + (sha256-bytevector + (bv-append opad + (sha256-bytevector + (bv-append ipad data-bv)))))) + + (def (hmac-md5 key data) + (error 'hmac-md5 "unsupported HMAC algorithm; hmac-sha256 is available")) + + (def (hmac-sha1 key data) + (error 'hmac-sha1 "unsupported HMAC algorithm; hmac-sha256 is available")) + + (def (hmac-sha384 key data) + (error 'hmac-sha384 "unsupported HMAC algorithm; hmac-sha256 is available")) + + (def (hmac-sha512 key data) + (error 'hmac-sha512 "unsupported HMAC algorithm; hmac-sha256 is available")) + + (def (->bytevector x) + (cond + [(bytevector? x) x] + [(string? x) (string->utf8 x)] + [else (error 'hmac "expected string or bytevector" x)])) + + (def (zero-pad bv size) + (let ([out (make-bytevector size 0)] + [n (min (bytevector-length bv) size)]) + (bytevector-copy! bv 0 out 0 n) + out)) + + (def (xor-pad bv byte) + (let* ([n (bytevector-length bv)] + [out (make-bytevector n)]) + (let loop ([i 0]) + (when (< i n) + (bytevector-u8-set! out i + (bitwise-xor (bytevector-u8-ref bv i) byte)) + (loop (+ i 1)))) + out)) + + (def (bv-append a b) + (let* ([alen (bytevector-length a)] + [blen (bytevector-length b)] + [out (make-bytevector (+ alen blen))]) + (bytevector-copy! a 0 out 0 alen) + (bytevector-copy! b 0 out alen blen) + out)) ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/markup/html.ss @@ -0,0 +1,6 @@ +#!chezscheme +;;; :std/markup/html -- HTML rendering facade + +(library (std markup html) + (export sxml->html sxml->xml sxml->string) + (import (std markup sxml-print))) --- a/lib/std/net/httpd.ss +++ b/lib/std/net/httpd.ss @@ -1,6 +1,9 @@ #!chezscheme -;;; :std/net/httpd -- HTTP server (wraps chez-httpd) -;;; Requires: jerboa-https (for chez-httpd), jerboa-ssl (with jerboa_ssl_shim.so) +;;; :std/net/httpd -- stable HTTP server facade +;;; +;;; Historically this module re-exported an external chez-httpd wrapper from +;;; (jerboa-https httpd). Keep the public std/net/httpd API available without +;;; requiring that optional package by adapting the in-tree thread HTTPD backend. (library (std net httpd) (export @@ -16,6 +19,180 @@ http-respond-chunk-begin http-respond-chunk http-respond-chunk-end http-respond-file) - (import (jerboa-https httpd)) + (import (chezscheme) + (prefix (std net thread-httpd) th:) + (std text json) + (only (jerboa core) def)) + + ;; ========== Server lifecycle ========== + + (def (httpd-config . options) + options) + + (def (httpd-start port-or-config handler) + (th:thread-httpd-start + (config-port port-or-config) + (adapt-handler handler))) + + (def (httpd-start-https . _) + (error 'httpd-start-https + "HTTPS is not available through std/net/httpd; use std/net/tls-rustls with a dedicated HTTP handler")) + + (def (httpd-stop server) + (th:thread-httpd-stop! server)) + + (def (config-port config) + (cond + [(number? config) config] + [(pair? config) + (let loop ([xs config]) + (cond + [(null? xs) 8080] + [(and (pair? (cdr xs)) + (or (eq? (car xs) 'port) + (eq? (car xs) 'port:))) + (cadr xs)] + [else (loop (cdr xs))]))] + [else 8080])) + + (def (adapt-handler handler) + (lambda (req) + (normalize-response + (if (procedure? handler) + (handler req) + (th:router-dispatch handler req))))) + + (def (normalize-response result) + (cond + [(th:response? result) result] + [(string? result) (th:respond-html 200 result)] + [(bytevector? result) (th:respond 200 '() result)] + [(not result) (th:respond-text 404 "Not Found")] + [else (th:respond-text 200 (format "~a" result))])) + + ;; ========== Router facade ========== + + (def make-router th:make-router) + + (def (router-add! router method path handler) + (th:router-add! router (method->string method) path handler) + router) + + (def (router-add-prefix! router prefix handler) + (router-add! router 'GET prefix handler)) + + (def router-lookup + (case-lambda + [(router req) (th:router-dispatch router req)] + [(router method path) + (th:router-dispatch router + (th:make-request (method->string method) path "HTTP/1.1" '() ""))])) + + (def (httpd-route router method path handler) + (router-add! router method path handler)) + + (def (httpd-route-prefix router prefix handler) + (router-add-prefix! router prefix handler)) + + (def (httpd-route-static router prefix directory) + (router-add-prefix! router prefix + (lambda (req) + (let* ([path (http-req-path req)] + [suffix (if (and (>= (string-length path) (string-length prefix)) + (string=? prefix (substring path 0 (string-length prefix)))) + (substring path (string-length prefix) (string-length path)) + "")] + [full-path (string-append directory "/" suffix)]) + (http-respond-file full-path))))) + + ;; ========== Request accessors ========== + + (def (http-req-method req) + (th:request-method req)) + + (def (http-req-path req) + (th:request-path-only req)) + + (def (http-req-query req) + (let ([q (th:request-query-string req)]) + (and (not (string=? q "")) q))) + + (def (http-req-version req) + (th:request-version req)) + + (def (http-req-headers req) + (th:request-headers req)) + + (def (http-req-header req name) + (th:request-header req name)) + + (def (http-req-body req) + (th:request-body req)) + + (def (http-req-client-addr req) + #f) + + ;; ========== Response helpers ========== + + (def http-respond + (case-lambda + [(status headers body) (th:respond status headers body)] + [(_res status headers body) (th:respond status headers body)])) + + (def http-respond-html + (case-lambda + [(body) (th:respond-html 200 body)] + [(status body) (th:respond-html status body)] + [(_res status body) (th:respond-html status body)])) + + (def http-respond-json + (case-lambda + [(body) (th:respond-json 200 (json-body->string body))] + [(status body) (th:respond-json status (json-body->string body))] + [(_res status body) (th:respond-json status (json-body->string body))])) + + (def (http-respond-error status message) + (th:respond-html status + (string-append "<h1>" (number->string status) "</h1><p>" message "</p>"))) + + (def http-respond-redirect + (case-lambda + [(location) (http-respond-redirect location 302)] + [(location status) + (th:respond status (list (cons "Location" location)) "")] + [(_res location status) + (th:respond status (list (cons "Location" location)) "")])) + + (def (http-respond-file path) + (if (file-exists? path) + (th:respond 200 + (list (cons "Content-Type" "application/octet-stream")) + (call-with-input-file path read-all-string)) + (http-respond-error 404 "Not Found"))) + + (def (http-respond-chunk-begin . _) + (th:respond 200 '() "")) + + (def (http-respond-chunk . _) + (void)) + + (def (http-respond-chunk-end . _) + (void)) + + (def (json-body->string body) + (if (string? body) body (json-object->string body))) + + (def (method->string method) + (cond + [(string? method) method] + [(symbol? method) (symbol->string method)] + [else (format "~a" method)])) + + (def (read-all-string port) + (let loop ([chars '()]) + (let ([ch (read-char port)]) + (if (eof-object? ch) + (list->string (reverse chars)) + (loop (cons ch chars)))))) ) ;; end library --- a/lib/std/net/tls-rustls.ss +++ b/lib/std/net/tls-rustls.ss @@ -61,62 +61,95 @@ ;; ========== FFI declarations ========== + (def (tls-native-unavailable who) + (lambda args + (error who + "TLS native support is unavailable; build or load libjerboa_native with jerboa_tls_* symbols"))) + ;; Standard TLS server context (no client auth) (def c-tls-server-new - (foreign-procedure "jerboa_tls_server_new" - (u8* unsigned-64 u8* unsigned-64) unsigned-64)) + (try + (foreign-procedure "jerboa_tls_server_new" + (u8* unsigned-64 u8* unsigned-64) unsigned-64) + (catch (e) (tls-native-unavailable 'rustls-server-ctx-new)))) ;; mTLS server context (requires client certs signed by given CA) (def c-tls-server-new-mtls - (foreign-procedure "jerboa_tls_server_new_mtls" - (u8* unsigned-64 u8* unsigned-64 u8* unsigned-64) unsigned-64)) + (try + (foreign-procedure "jerboa_tls_server_new_mtls" + (u8* unsigned-64 u8* unsigned-64 u8* unsigned-64) unsigned-64) + (catch (e) (tls-native-unavailable 'rustls-server-ctx-new-mtls)))) (def c-tls-server-free - (foreign-procedure "jerboa_tls_server_free" (unsigned-64) void)) + (try + (foreign-procedure "jerboa_tls_server_free" (unsigned-64) void) + (catch (e) (tls-native-unavailable 'rustls-server-ctx-free)))) ;; Accept a TLS connection on an already-accepted TCP fd (def c-tls-accept - (foreign-procedure __collect_safe "jerboa_tls_accept" (unsigned-64 int) unsigned-64)) + (try + (foreign-procedure __collect_safe "jerboa_tls_accept" (unsigned-64 int) unsigned-64) + (catch (e) (tls-native-unavailable 'rustls-accept)))) ;; Standard TLS client connect (system CA trust) (def c-tls-connect - (foreign-procedure __collect_safe "jerboa_tls_connect" - (u8* unsigned-64 unsigned-16) unsigned-64)) + (try + (foreign-procedure __collect_safe "jerboa_tls_connect" + (u8* unsigned-64 unsigned-16) unsigned-64) + (catch (e) (tls-native-unavailable 'rustls-connect)))) ;; TLS client with certificate pinning (no CA verification) (def c-tls-connect-pinned - (foreign-procedure __collect_safe "jerboa_tls_connect_pinned" - (u8* unsigned-64 unsigned-16 u8* unsigned-64) unsigned-64)) + (try + (foreign-procedure __collect_safe "jerboa_tls_connect_pinned" + (u8* unsigned-64 unsigned-16 u8* unsigned-64) unsigned-64) + (catch (e) (tls-native-unavailable 'rustls-connect-pinned)))) ;; mTLS client connect (presents client cert, verifies server against CA) (def c-tls-connect-mtls - (foreign-procedure __collect_safe "jerboa_tls_connect_mtls" - (u8* unsigned-64 unsigned-16 - u8* unsigned-64 u8* unsigned-64 u8* unsigned-64) unsigned-64)) + (try + (foreign-procedure __collect_safe "jerboa_tls_connect_mtls" + (u8* unsigned-64 unsigned-16 + u8* unsigned-64 u8* unsigned-64 u8* unsigned-64) unsigned-64) + (catch (e) (tls-native-unavailable 'rustls-connect-mtls)))) ;; I/O (def c-tls-read - (foreign-procedure __collect_safe "jerboa_tls_read" (unsigned-64 u8* unsigned-64) int)) + (try + (foreign-procedure __collect_safe "jerboa_tls_read" (unsigned-64 u8* unsigned-64) int) + (catch (e) (tls-native-unavailable 'rustls-read)))) (def c-tls-write - (foreign-procedure __collect_safe "jerboa_tls_write" (unsigned-64 u8* unsigned-64) int)) + (try + (foreign-procedure __collect_safe "jerboa_tls_write" (unsigned-64 u8* unsigned-64) int) + (catch (e) (tls-native-unavailable 'rustls-write)))) (def c-tls-flush - (foreign-procedure __collect_safe "jerboa_tls_flush" (unsigned-64) int)) + (try + (foreign-procedure __collect_safe "jerboa_tls_flush" (unsigned-64) int) + (catch (e) (tls-native-unavailable 'rustls-flush)))) (def c-tls-close - (foreign-procedure "jerboa_tls_close" (unsigned-64) void)) + (try + (foreign-procedure "jerboa_tls_close" (unsigned-64) void) + (catch (e) (tls-native-unavailable 'rustls-close)))) ;; Utilities (def c-tls-set-nonblock - (foreign-procedure "jerboa_tls_set_nonblock" (unsigned-64 int) int)) + (try + (foreign-procedure "jerboa_tls_set_nonblock" (unsigned-64 int) int) + (catch (e) (tls-native-unavailable 'rustls-set-nonblock)))) (def c-tls-get-fd - (foreign-procedure "jerboa_tls_get_fd" (unsigned-64) int)) + (try + (foreign-procedure "jerboa_tls_get_fd" (unsigned-64) int) + (catch (e) (tls-native-unavailable 'rustls-get-fd)))) ;; Error reporting (def c-last-error - (foreign-procedure "jerboa_last_error" (u8* size_t) size_t)) + (try + (foreign-procedure "jerboa_last_error" (u8* size_t) size_t) + (catch (e) (lambda (buf size) 0)))) (def (get-last-error) (let ([buf (make-bytevector 512)]) --- a/lib/std/net/uri.ss +++ b/lib/std/net/uri.ss @@ -8,6 +8,8 @@ uri-encode uri-decode uri->string query-string->alist + form-url-decode + form-url-encode alist->query-string) (import (chezscheme) (only (jerboa core) def defstruct)) @@ -235,4 +237,8 @@ (lp (cdr pairs) #f))) (get-output-string out))) + ;; Gerbil/Gambit compatibility names. + (def form-url-decode query-string->alist) + (def form-url-encode alist->query-string) + ) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-gerbil-sinatra-compat.ss @@ -0,0 +1,82 @@ +#!chezscheme +;;; test-gerbil-sinatra-compat.ss -- compatibility used by gerbil-sinatra ports + +(import (chezscheme) + (std net httpd) + (std markup html) + (std net uri) + (std crypto) + (std text base64)) + +(define pass-count 0) +(define fail-count 0) + +(define-syntax check + (syntax-rules (=>) + [(_ expr => expected) + (let ([result expr] [exp expected]) + (if (equal? result exp) + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (display "FAIL: ") (write 'expr) + (display " => ") (write result) + (display " expected ") (write exp) + (newline))))])) + +(define-syntax check-true + (syntax-rules () + [(_ expr) + (let ([result expr]) + (if result + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (display "FAIL: ") (write 'expr) + (display " expected truthy, got ") (write result) + (newline))))])) + +(define hex-digits "0123456789abcdef") + +(define (bytevector->hex bv) + (let* ([n (bytevector-length bv)] + [out (make-string (* n 2))]) + (do ([i 0 (+ i 1)]) + ((= i n) out) + (let ([b (bytevector-u8-ref bv i)]) + (string-set! out (* i 2) + (string-ref hex-digits (quotient b 16))) + (string-set! out (+ (* i 2) 1) + (string-ref hex-digits (remainder b 16))))))) + +(check (sxml->html '(p "hi")) => "<p>hi</p>") + +(let ([params (form-url-decode "name=Alice+Smith&x=1")]) + (check (cdr (assoc "name" params)) => "Alice Smith") + (check (cdr (assoc "x" params)) => "1")) + +(check (form-url-encode '(("x" . "1"))) => "x=1") + +(check (bytevector-length (random-bytes 8)) => 8) +(check-true (string? (u8vector->base64-string (random-bytes 4)))) +(check-true (bytevector? (hmac-sha256 (string->utf8 "key") + (string->utf8 "message")))) +(check (bytevector->hex + (hmac-sha256 "Jefe" "what do ya want for nothing?")) + => "5bdcc146bf60754e6a042426089575c75a003f089d2739839dec58b964ec3843") + +(let ([r (make-router)]) + (router-add! r 'GET "/hello" + (lambda (req) (http-respond-html 200 "ok"))) + (let ([resp (router-lookup r 'GET "/hello")]) + (check-true resp))) + +(let ([resp (http-respond-json 201 "[]")]) + (check-true resp)) + +(display " gerbil-sinatra-compat: ") +(display pass-count) (display " passed") +(when (> fail-count 0) + (display ", ") (display fail-count) (display " failed")) +(newline) +(when (> fail-count 0) (exit 1))