fiber-httpd: fiber-native HTTP/1.1 server — (std net fiber-httpd)
ober
d8d43fa265b0c8bc7d0c176dcbe1b31a63dea0ab
new file mode 100644 --- /dev/null +++ b/lib/std/net/fiber-httpd.sls @@ -0,0 +1,395 @@ +#!chezscheme +;;; (std net fiber-httpd) — Fiber-Native HTTP/1.1 Server +;;; +;;; One fiber per connection, epoll-backed accept loop. +;;; Zero external dependencies — pure Scheme HTTP parser. +;;; +;;; API: +;;; (fiber-httpd-start port handler) — start server, returns control record +;;; (fiber-httpd-start* opts handler) — start with options +;;; (fiber-httpd-stop! server) — graceful shutdown +;;; +;;; handler: (lambda (req) ...) → response +;;; request: (method path version headers body) +;;; response: (status headers body) +;;; +;;; (make-request method path version headers body) +;;; (request-method req) (request-path req) (request-version req) +;;; (request-headers req) (request-body req) +;;; (request-header req name) +;;; +;;; (respond status headers body) +;;; (respond-text status text) +;;; (respond-json status json-string) +;;; +;;; (make-router) (router-add! r method path handler) (router-dispatch r req) +;;; (GET path handler) (POST path handler) ... + +(library (std net fiber-httpd) + (export + ;; Server lifecycle + fiber-httpd-start + fiber-httpd-stop! + fiber-httpd? + fiber-httpd-listen-port + + ;; Request record + make-request request? request-method request-path request-version + request-headers request-body request-header + request-query-string request-path-only + + ;; Response helpers + respond respond-text respond-json respond-html + response? response-status response-headers response-body + + ;; Router + make-router router-add! router-dispatch + route-get route-post route-put route-delete) + + (import (chezscheme) + (std fiber) + (std net io)) + + ;; ========== Request record ========== + + (define-record-type request + (fields method path version headers body) + (sealed #t)) + + (define (request-header req name) + (let ([entry (assoc name (request-headers req))]) + (and entry (cdr entry)))) + + (define (request-path-only req) + (let ([p (request-path req)]) + (let ([idx (string-index p #\?)]) + (if idx (substring p 0 idx) p)))) + + (define (request-query-string req) + (let ([p (request-path req)]) + (let ([idx (string-index p #\?)]) + (if idx (substring p (+ idx 1) (string-length p)) "")))) + + (define (string-index s ch) + (let loop ([i 0]) + (cond + [(= i (string-length s)) #f] + [(char=? (string-ref s i) ch) i] + [else (loop (+ i 1))]))) + + ;; ========== Response record ========== + + (define-record-type response + (fields status headers body) + (sealed #t)) + + (define (respond status headers body) + (make-response status headers body)) + + (define (respond-text status text) + (make-response status + '(("Content-Type" . "text/plain; charset=utf-8")) + text)) + + (define (respond-json status json-str) + (make-response status + '(("Content-Type" . "application/json")) + json-str)) + + (define (respond-html status html) + (make-response status + '(("Content-Type" . "text/html; charset=utf-8")) + html)) + + ;; ========== HTTP Parser ========== + ;; + ;; Reads HTTP/1.1 requests from a raw fd using fiber-aware I/O. + ;; Returns a request record or #f on connection close/error. + + (define *max-header-size* 8192) + (define *max-body-size* (* 10 1024 1024)) ;; 10MB + + ;; Read bytes from fd into a bytevector buffer, growing as needed. + ;; Returns (values buf filled) where filled is total bytes in buf. + ;; Reads until we find \r\n\r\n (end of headers) or hit max. + (define (read-until-headers fd poller) + (let ([buf (make-bytevector *max-header-size*)] + [tmp (make-bytevector 4096)]) + (let loop ([filled 0]) + (if (>= filled *max-header-size*) + (values buf filled) ;; hit limit + (let ([n (fiber-tcp-read fd tmp + (min 4096 (- *max-header-size* filled)) + poller)]) + (cond + [(<= n 0) (values buf filled)] ;; EOF or error + [else + (bytevector-copy! tmp 0 buf filled n) + (let ([total (+ filled n)]) + ;; Check for \r\n\r\n + (if (header-complete? buf total) + (values buf total) + (loop total)))])))))) + + (define (header-complete? buf len) + (let loop ([i 0]) + (cond + [(> (+ i 3) len) #f] + [(and (= (bytevector-u8-ref buf i) 13) ;; \r + (= (bytevector-u8-ref buf (+ i 1)) 10) ;; \n + (= (bytevector-u8-ref buf (+ i 2)) 13) ;; \r + (= (bytevector-u8-ref buf (+ i 3)) 10)) ;; \n + #t] + [else (loop (+ i 1))]))) + + ;; Find the offset of \r\n\r\n in buffer + (define (find-header-end buf len) + (let loop ([i 0]) + (cond + [(> (+ i 3) len) len] + [(and (= (bytevector-u8-ref buf i) 13) + (= (bytevector-u8-ref buf (+ i 1)) 10) + (= (bytevector-u8-ref buf (+ i 2)) 13) + (= (bytevector-u8-ref buf (+ i 3)) 10)) + (+ i 4)] + [else (loop (+ i 1))]))) + + ;; Parse the header portion into a request record. + (define (parse-request-headers buf header-end) + (let* ([header-str (utf8->string + (let ([b (make-bytevector header-end)]) + (bytevector-copy! buf 0 b 0 header-end) b))] + [lines (string-split-crlf header-str)]) + (if (null? lines) #f + (let ([req-line (car lines)] + [header-lines (cdr lines)]) + (let ([parts (string-split-spaces req-line)]) + (if (< (length parts) 3) #f + (let ([method (car parts)] + [path (cadr parts)] + [version (caddr parts)] + [headers (parse-headers header-lines)]) + (make-request method path version headers #f)))))))) + + (define (string-split-crlf s) + (let loop ([start 0] [acc '()]) + (let ([idx (string-search s "\r\n" start)]) + (if idx + (let ([line (substring s start idx)]) + (if (= (string-length line) 0) + (reverse acc) + (loop (+ idx 2) (cons line acc)))) + (let ([rest (substring s start (string-length s))]) + (reverse (if (= (string-length rest) 0) acc (cons rest acc)))))))) + + (define (string-search s needle start) + (let ([slen (string-length s)] + [nlen (string-length needle)]) + (let loop ([i start]) + (cond + [(> (+ i nlen) slen) #f] + [(string=? (substring s i (+ i nlen)) needle) i] + [else (loop (+ i 1))])))) + + (define (string-split-spaces s) + (let loop ([i 0] [start 0] [acc '()]) + (cond + [(= i (string-length s)) + (reverse (if (= start i) acc + (cons (substring s start i) acc)))] + [(char=? (string-ref s i) #\space) + (loop (+ i 1) (+ i 1) + (if (= start i) acc (cons (substring s start i) acc)))] + [else (loop (+ i 1) start acc)]))) + + (define (parse-headers lines) + (let loop ([ls lines] [acc '()]) + (if (null? ls) (reverse acc) + (let* ([line (car ls)] + [colon (string-index line #\:)]) + (if colon + (let ([name (string-downcase (substring line 0 colon))] + [value (string-trim-left (substring line (+ colon 1) (string-length line)))]) + (loop (cdr ls) (cons (cons name value) acc))) + (loop (cdr ls) acc)))))) + + (define (string-trim-left s) + (let loop ([i 0]) + (if (and (< i (string-length s)) (char=? (string-ref s i) #\space)) + (loop (+ i 1)) + (substring s i (string-length s))))) + + ;; Read the body based on Content-Length + (define (read-body fd poller buf header-end filled content-length) + (if (or (not content-length) (= content-length 0)) + #f + (let* ([already-have (- filled header-end)] + [need (- content-length already-have)] + [body-buf (make-bytevector content-length)]) + ;; Copy what we already have + (when (> already-have 0) + (bytevector-copy! buf header-end body-buf 0 + (min already-have content-length))) + ;; Read the rest + (when (> need 0) + (let loop ([got already-have]) + (when (< got content-length) + (let ([tmp (make-bytevector (min 4096 (- content-length got)))]) + (let ([n (fiber-tcp-read fd tmp + (min 4096 (- content-length got)) poller)]) + (when (> n 0) + (bytevector-copy! tmp 0 body-buf got n) + (loop (+ got n)))))))) + (utf8->string body-buf)))) + + ;; Full request read + (define (read-request fd poller) + (let-values ([(buf filled) (read-until-headers fd poller)]) + (if (= filled 0) #f ;; connection closed + (let ([header-end (find-header-end buf filled)]) + (let ([req (parse-request-headers buf header-end)]) + (if (not req) #f + (let ([cl-str (request-header req "content-length")]) + (let ([content-length (and cl-str (string->number cl-str))]) + (let ([body (read-body fd poller buf header-end filled content-length)]) + (make-request (request-method req) (request-path req) + (request-version req) (request-headers req) + body)))))))))) + + ;; ========== HTTP Response Writer ========== + + (define (status-text code) + (case code + [(200) "OK"] [(201) "Created"] [(204) "No Content"] + [(301) "Moved Permanently"] [(302) "Found"] [(304) "Not Modified"] + [(400) "Bad Request"] [(401) "Unauthorized"] [(403) "Forbidden"] + [(404) "Not Found"] [(405) "Method Not Allowed"] + [(500) "Internal Server Error"] [(502) "Bad Gateway"] + [(503) "Service Unavailable"] + [else "Unknown"])) + + (define (write-response fd poller resp) + (let* ([status (response-status resp)] + [headers (response-headers resp)] + [body (response-body resp)] + [body-bv (cond + [(not body) (make-bytevector 0)] + [(string? body) + (string->bytevector body (make-transcoder (utf-8-codec)))] + [(bytevector? body) body] + [else (string->bytevector (format "~a" body) + (make-transcoder (utf-8-codec)))])] + [status-line (format "HTTP/1.1 ~a ~a\r\n" status (status-text status))] + ;; Build header string + [header-str + (let ([h (string-append + status-line + (format "Content-Length: ~a\r\n" (bytevector-length body-bv)) + (apply string-append + (map (lambda (hdr) + (format "~a: ~a\r\n" (car hdr) (cdr hdr))) + headers)) + "\r\n")]) + h)] + [header-bv (string->bytevector header-str (make-transcoder (utf-8-codec)))]) + ;; Write headers + (fiber-tcp-write fd header-bv (bytevector-length header-bv) poller) + ;; Write body + (when (> (bytevector-length body-bv) 0) + (fiber-tcp-write fd body-bv (bytevector-length body-bv) poller)))) + + ;; ========== Router ========== + + (define-record-type router + (fields (mutable routes)) ;; list of (method path-pattern handler) + (protocol + (lambda (new) (lambda () (new '()))))) + + (define (router-add! r method path handler) + (router-routes-set! r + (cons (list method path handler) (router-routes r)))) + + ;; Simple prefix/exact matching with :param support + (define (path-match? pattern path) + (or (string=? pattern path) + (string=? pattern "*"))) + + (define (router-dispatch r req) + (let ([method (request-method req)] + [path (request-path-only req)]) + (let loop ([routes (router-routes r)]) + (if (null? routes) + (respond-text 404 "Not Found") + (let ([route (car routes)]) + (if (and (string=? (car route) method) + (path-match? (cadr route) path)) + ((caddr route) req) + (loop (cdr routes)))))))) + + ;; Convenience route adders + (define (route-get r path handler) (router-add! r "GET" path handler)) + (define (route-post r path handler) (router-add! r "POST" path handler)) + (define (route-put r path handler) (router-add! r "PUT" path handler)) + (define (route-delete r path handler) (router-add! r "DELETE" path handler)) + + ;; ========== Server ========== + + (define-record-type fiber-httpd + (fields (immutable listen-fd) + (immutable listen-port) + (immutable runtime) + (immutable poller) + (mutable running?)) + (sealed #t)) + + ;; Connection handler: one fiber per connection, keep-alive loop + (define (handle-connection fd poller handler) + (let loop () + (let ([req (read-request fd poller)]) + (when req + (let ([resp (guard (exn [#t + (respond-text 500 + (if (message-condition? exn) + (condition-message exn) + "Internal Server Error"))]) + (handler req))]) + (when (response? resp) + (write-response fd poller resp) + ;; Keep-alive: check Connection header + (let ([conn (request-header req "connection")]) + (unless (and conn (string=? (string-downcase conn) "close")) + (loop)))))))) + (fiber-tcp-close fd)) + + ;; Accept loop + (define (accept-loop listen-fd poller handler) + (let loop () + (guard (exn [#t (void)]) ;; stop on error (e.g., fd closed) + (let ([client-fd (fiber-tcp-accept listen-fd poller)]) + (fiber-spawn* + (lambda () (handle-connection client-fd poller handler)) + "http-conn") + (loop))))) + + ;; Start the server + (define (fiber-httpd-start port handler) + (let* ([rt (make-fiber-runtime)] + [poller (make-io-poller rt)]) + (io-poller-start! poller) + (let-values ([(listen-fd listen-port) (fiber-tcp-listen "0.0.0.0" port)]) + (let ([srv (make-fiber-httpd listen-fd listen-port rt poller #t)]) + ;; Spawn accept loop + (fiber-spawn rt + (lambda () (accept-loop listen-fd poller handler)) + "httpd-accept") + ;; Run in background thread so caller gets the server handle back + (fork-thread (lambda () (fiber-runtime-run! rt))) + srv)))) + + (define (fiber-httpd-stop! srv) + (fiber-httpd-running?-set! srv #f) + (fiber-tcp-close (fiber-httpd-listen-fd srv)) + (io-poller-stop! (fiber-httpd-poller srv)) + (fiber-runtime-stop! (fiber-httpd-runtime srv))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-fiber-httpd.ss @@ -0,0 +1,300 @@ +;;; Test fiber-native HTTP/1.1 server. +;;; Tests Phase 2 of green-wins: fiber-httpd with real TCP connections. + +(import (chezscheme)) +(import (std fiber)) +(import (std net io)) +(import (std net fiber-httpd)) + +(define test-count 0) +(define pass-count 0) + +(define-syntax test + (syntax-rules () + [(_ name body ...) + (begin + (set! test-count (+ test-count 1)) + (guard (exn [#t + (display "FAIL: ") (display name) (newline) + (display " Error: ") + (display (if (message-condition? exn) (condition-message exn) exn)) + (newline)]) + body ... + (set! pass-count (+ pass-count 1)) + (display "PASS: ") (display name) (newline)))])) + +(define-syntax assert-equal + (syntax-rules () + [(_ got expected msg) + (unless (equal? got expected) + (error 'assert msg (list 'got: got 'expected: expected)))])) + +(define-syntax assert-true + (syntax-rules () + [(_ val msg) + (unless val (error 'assert msg))])) + +;; Helper: send raw HTTP request over a fiber-aware TCP connection +;; and read the full response. +(define (http-request-raw fd poller method path body) + (let* ([body-bv (if body + (string->bytevector body (make-transcoder (utf-8-codec))) + #f)] + [req-str (string-append + method " " path " HTTP/1.1\r\n" + "Host: localhost\r\n" + (if body-bv + (string-append "Content-Length: " + (number->string (bytevector-length body-bv)) + "\r\n") + "") + "Connection: close\r\n" + "\r\n")] + [req-bv (string->bytevector req-str (make-transcoder (utf-8-codec)))]) + ;; Send request + (fiber-tcp-write fd req-bv (bytevector-length req-bv) poller) + ;; Send body if present + (when body-bv + (fiber-tcp-write fd body-bv (bytevector-length body-bv) poller)) + ;; Read response + (let ([buf (make-bytevector 16384)]) + (let loop ([total 0]) + (let ([n (fiber-tcp-read fd buf (- 16384 total) poller)]) + (cond + [(<= n 0) + ;; EOF — return what we have + (bytevector->string + (let ([b (make-bytevector total)]) + (bytevector-copy! buf 0 b 0 total) b) + (make-transcoder (utf-8-codec)))] + [else + (loop (+ total n))])))))) + +;; Helper: parse response status code from raw response +(define (response-status-code resp) + (let ([space1 (string-index-helper resp #\space 0)]) + (when space1 + (let ([space2 (string-index-helper resp #\space (+ space1 1))]) + (when space2 + (string->number (substring resp (+ space1 1) space2))))))) + +;; Helper: extract response body (after \r\n\r\n) +(define (response-body-text resp) + (let ([idx (string-search-helper resp "\r\n\r\n" 0)]) + (if idx + (substring resp (+ idx 4) (string-length resp)) + ""))) + +(define (string-index-helper s ch start) + (let loop ([i start]) + (cond + [(= i (string-length s)) #f] + [(char=? (string-ref s i) ch) i] + [else (loop (+ i 1))]))) + +(define (string-search-helper s needle start) + (let ([slen (string-length s)] + [nlen (string-length needle)]) + (let loop ([i start]) + (cond + [(> (+ i nlen) slen) #f] + [(string=? (substring s i (+ i nlen)) needle) i] + [else (loop (+ i 1))])))) + +;; ========================================================================= +;; Test 1: Request record accessors +;; ========================================================================= + +(test "request record accessors" + (let ([req (make-request "GET" "/hello?name=world" "HTTP/1.1" + '(("host" . "localhost") ("content-type" . "text/plain")) + "body-data")]) + (assert-equal (request-method req) "GET" "method") + (assert-equal (request-path req) "/hello?name=world" "path") + (assert-equal (request-version req) "HTTP/1.1" "version") + (assert-equal (request-header req "host") "localhost" "header") + (assert-equal (request-header req "content-type") "text/plain" "ct header") + (assert-equal (request-header req "missing") #f "missing header") + (assert-equal (request-body req) "body-data" "body") + (assert-equal (request-path-only req) "/hello" "path-only") + (assert-equal (request-query-string req) "name=world" "query-string"))) + +;; ========================================================================= +;; Test 2: Response helpers +;; ========================================================================= + +(test "response helpers" + (let ([r1 (respond 200 '(("X-Custom" . "yes")) "ok")]) + (assert-true (response? r1) "is response") + (assert-equal (response-status r1) 200 "status") + (assert-equal (response-body r1) "ok" "body")) + + (let ([r2 (respond-text 201 "created")]) + (assert-equal (response-status r2) 201 "text status") + (assert-equal (response-body r2) "created" "text body")) + + (let ([r3 (respond-json 200 "{\"key\":\"val\"}")]) + (assert-equal (response-status r3) 200 "json status")) + + (let ([r4 (respond-html 200 "<h1>Hi</h1>")]) + (assert-equal (response-status r4) 200 "html status"))) + +;; ========================================================================= +;; Test 3: Router +;; ========================================================================= + +(test "router dispatch" + (let ([r (make-router)]) + (route-get r "/" (lambda (req) (respond-text 200 "home"))) + (route-get r "/hello" (lambda (req) (respond-text 200 "hello"))) + (route-post r "/data" (lambda (req) (respond-text 201 "created"))) + + ;; Match GET / + (let ([resp (router-dispatch r (make-request "GET" "/" "HTTP/1.1" '() #f))]) + (assert-equal (response-status resp) 200 "GET / status") + (assert-equal (response-body resp) "home" "GET / body")) + + ;; Match GET /hello + (let ([resp (router-dispatch r (make-request "GET" "/hello" "HTTP/1.1" '() #f))]) + (assert-equal (response-status resp) 200 "GET /hello status") + (assert-equal (response-body resp) "hello" "GET /hello body")) + + ;; Match POST /data + (let ([resp (router-dispatch r (make-request "POST" "/data" "HTTP/1.1" '() #f))]) + (assert-equal (response-status resp) 201 "POST /data status")) + + ;; 404 for unmatched route + (let ([resp (router-dispatch r (make-request "GET" "/nope" "HTTP/1.1" '() #f))]) + (assert-equal (response-status resp) 404 "404 status")))) + +;; ========================================================================= +;; Test 4: Live HTTP server — single request +;; ========================================================================= + +(test "live HTTP server — single request" + (let ([rt (make-fiber-runtime 4)]) + (with-io-poller rt poller + (let-values ([(listen-fd listen-port) (fiber-tcp-listen "127.0.0.1" 0)]) + ;; Server fiber: accept one connection and handle it + (fiber-spawn rt + (lambda () + (let ([client-fd (fiber-tcp-accept listen-fd poller)]) + ;; Read request + (let ([buf (make-bytevector 4096)]) + (let ([n (fiber-tcp-read client-fd buf 4096 poller)]) + ;; Send a simple HTTP response + (let* ([resp-body "Hello from fiber-httpd!"] + [resp-str (string-append + "HTTP/1.1 200 OK\r\n" + "Content-Length: " (number->string (string-length resp-body)) "\r\n" + "Connection: close\r\n" + "\r\n" + resp-body)] + [resp-bv (string->bytevector resp-str (make-transcoder (utf-8-codec)))]) + (fiber-tcp-write client-fd resp-bv (bytevector-length resp-bv) poller)))) + (fiber-tcp-close client-fd))) + "test-server") + + ;; Client fiber: connect, send GET, read response + (fiber-spawn rt + (lambda () + (fiber-sleep 20) + (let ([fd (fiber-tcp-connect "127.0.0.1" listen-port poller)]) + (let ([resp (http-request-raw fd poller "GET" "/" #f)]) + (assert-true (> (string-length resp) 0) "got response") + (assert-equal (response-status-code resp) 200 "status 200") + (assert-equal (response-body-text resp) "Hello from fiber-httpd!" + "body matches")) + (fiber-tcp-close fd))) + "test-client") + + (fiber-runtime-run! rt) + (fiber-tcp-close listen-fd))))) + +;; ========================================================================= +;; Test 5: Full fiber-httpd-start / stop cycle with real HTTP +;; ========================================================================= + +(test "fiber-httpd-start/stop with real requests" + (let* ([handler (lambda (req) + (cond + [(string=? (request-path req) "/ping") + (respond-text 200 "pong")] + [(string=? (request-path req) "/echo") + (respond-text 200 (or (request-body req) ""))] + [else + (respond-text 404 "not found")]))] + [srv (fiber-httpd-start 0 handler)] + [port (fiber-httpd-listen-port srv)]) + + ;; Give server a moment to start + (sleep (make-time 'time-duration 100000000 0)) ;; 100ms + + ;; Use a separate fiber runtime for the client side + (let ([rt (make-fiber-runtime 2)]) + (with-io-poller rt poller + ;; Client: GET /ping + (fiber-spawn rt + (lambda () + (let ([fd (fiber-tcp-connect "127.0.0.1" port poller)]) + (let ([resp (http-request-raw fd poller "GET" "/ping" #f)]) + (assert-equal (response-status-code resp) 200 "/ping status") + (assert-equal (response-body-text resp) "pong" "/ping body")) + (fiber-tcp-close fd))) + "client-ping") + + (fiber-runtime-run! rt))) + + ;; Stop the server + (fiber-httpd-stop! srv))) + +;; ========================================================================= +;; Test 6: Multiple concurrent HTTP requests +;; ========================================================================= + +(test "10 concurrent HTTP requests" + (let* ([handler (lambda (req) + (respond-text 200 + (string-append "reply-" (request-path req))))] + [srv (fiber-httpd-start 0 handler)] + [port (fiber-httpd-listen-port srv)] + [num-clients 10] + [results (make-vector num-clients #f)]) + + (sleep (make-time 'time-duration 100000000 0)) ;; 100ms + + (let ([rt (make-fiber-runtime 4)]) + (with-io-poller rt poller + (do ([i 0 (+ i 1)]) + ((= i num-clients)) + (let ([idx i]) + (fiber-spawn rt + (lambda () + (let ([fd (fiber-tcp-connect "127.0.0.1" port poller)]) + (let ([resp (http-request-raw fd poller "GET" + (string-append "/req-" (number->string idx)) #f)]) + (let ([body (response-body-text resp)]) + (vector-set! results idx + (string=? body (string-append "reply-/req-" (number->string idx)))))) + (fiber-tcp-close fd))) + (string-append "client-" (number->string idx))))) + + (fiber-runtime-run! rt))) + + (fiber-httpd-stop! srv) + + ;; Verify all clients got correct responses + (let ([ok (do ([i 0 (+ i 1)] [c 0 (+ c (if (vector-ref results i) 1 0))]) + ((= i num-clients) c))]) + (assert-equal ok num-clients "all clients got correct responses")))) + +;; ========================================================================= +;; Summary +;; ========================================================================= +(newline) +(display "=========================================") (newline) +(display "Results: ") (display pass-count) (display "/") +(display test-count) (display " passed") (newline) +(display "=========================================") (newline) +(when (< pass-count test-count) + (exit 1))