Add native HTTP/1.1 client over TLS for Chez Scheme
ober
0b3b3e9d04afa71a8ed7afaec89cdaf7b13d6d51
new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +*.so +*.o new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,25 @@ +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 + +LIBDIRS = src:$(SSL_DIR)/src:$(ZLIB_DIR)/src + +.PHONY: all test test-unit clean deps + +all: + @echo "chez-https is a pure Scheme library. Run 'make test' to test." + +# Build chez-ssl shared object if not already built +deps: + @test -f $(SSL_DIR)/chez_ssl_shim.so || $(MAKE) -C $(SSL_DIR) + +test: deps + @ln -sf $(realpath $(SSL_DIR))/chez_ssl_shim.so ./chez_ssl_shim.so + $(CHEZ) --libdirs "$(LIBDIRS)" --script tests/https-test.ss + +clean: + @echo "Nothing to clean (pure Scheme library)." --- a/README.md +++ b/README.md @@ -1 +1,116 @@ # chez-https + +Native HTTP/1.1 client over TLS for Chez Scheme. No subprocesses. No curl. Pure in-process HTTPS. + +## Dependencies + +- [chez-ssl](https://github.com/ober/chez-ssl) — TLS transport layer +- [chez-zlib](https://github.com/ober/chez-zlib) — zlib compression (optional, for decompressing gzip response bodies) +- Chez Scheme 10.x +- OpenSSL (`libssl`, `libcrypto`) + +## Installation + +```bash +# Clone dependencies +git clone https://github.com/ober/chez-ssl.git ~/mine/chez-ssl +git clone https://github.com/ober/chez-zlib.git ~/mine/chez-zlib + +# Build chez-ssl +cd ~/mine/chez-ssl && make + +# Clone this library +git clone https://github.com/ober/chez-https.git ~/mine/chez-https +``` + +## Usage + +```scheme +(import (chez-https)) + +;; Simple GET +(let ([req (http-get "https://example.com/")]) + (display (request-status req)) ;; 200 + (display (request-text req)) ;; HTML body as string + (request-close req)) + +;; With headers and query parameters (S3-compatible format) +(let ([headers (list (list "Authorization" ':: "AWS4-HMAC-SHA256 ...") + ':: + (list "Host" ':: "bucket.s3.amazonaws.com") + (list "x-amz-date" ':: "20260306T120000Z"))] + [params (list (list "list-type" ':: "2") + (list "prefix" ':: "AWSLogs/"))]) + (let ([req (http-get url 'headers: headers 'params: params)]) + (display (request-status req)) + (request-close req))) + +;; PUT with body +(let ([req (http-put url + 'headers: headers + 'params: #f + 'data: (string->utf8 "request body"))]) + (display (request-status req)) + (request-close req)) +``` + +## API + +### HTTP Methods + +```scheme +(http-get url ['headers: hdrs] ['params: params]) +(http-post url ['headers: hdrs] ['params: params] ['data: body]) +(http-put url ['headers: hdrs] ['params: params] ['data: body]) +(http-delete url ['headers: hdrs] ['params: params]) +(http-head url ['headers: hdrs] ['params: params]) +``` + +### Response Accessors + +| Function | Returns | Description | +|----------|---------|-------------| +| `(request-status req)` | integer | HTTP status code (200, 404, etc.) | +| `(request-text req)` | string | Response body as UTF-8 string | +| `(request-content req)` | bytevector | Response body as raw bytes | +| `(request-headers req)` | alist | Response headers (lowercase keys) | +| `(request-header req name)` | string or `#f` | Single header value lookup | +| `(request-close req)` | void | No-op (connection already closed) | + +### Utilities + +| Function | Description | +|----------|-------------| +| `(parse-url url)` | Returns `(values host port path)` | +| `(url-encode str)` | RFC 3986 percent-encoding | +| `(flatten-request-headers hdrs)` | Flatten `(name :: value)` format to alist | +| `(build-query-string params)` | Build URL query string from params | + +## Features + +- HTTPS via OpenSSL (TLS 1.2/1.3) +- SNI and hostname verification +- Chunked transfer encoding +- 100 Continue handling +- Binary response body preservation (critical for gzip/binary downloads) +- S3-compatible header format (`::` separator convention) +- URL encoding (RFC 3986) +- Automatic SSL initialization + +## Testing + +```bash +make test +``` + +## Architecture + +``` +chez-https (this library) + │ + └── chez-ssl (TLS transport) + │ + └── OpenSSL (libssl, libcrypto) +``` + +`chez-https` is a pure Scheme library with no C code. All native I/O goes through `chez-ssl`. new file mode 100644 --- /dev/null +++ b/chez-https.md @@ -0,0 +1,311 @@ +# chez-https — Chez Scheme Native HTTP/1.1 Client over TLS + +## Purpose + +Provide a complete HTTP/1.1 client for Chez Scheme that works over TLS (HTTPS). This builds on top of `chez-ssl` (the TLS transport layer) and provides the same API as the current `(compat request)` module so it's a drop-in replacement. No subprocesses. No curl. Pure in-process networking. + +## Why This Is Needed + +This project (`gherkin-kunabi`) currently shells out to `curl` for every HTTP request. With 27,000+ S3 objects to download, that spawns 27,000+ subprocesses, causing catastrophic memory leaks. This library replaces all of that with native in-process HTTPS. + +## Dependencies + +- **`chez-ssl`** — provides `ssl-connect`, `ssl-read`, `ssl-write`, `ssl-read-all`, `ssl-close` +- Chez Scheme 10.x (R6RS) + +## Library Interface + +Must match the existing `(compat request)` API so s3-api.sls doesn't need changes: + +```scheme +(library (compat request) + (export http-get http-post http-put http-delete http-head + request-status request-text request-content + request-headers request-close) + (import (chezscheme) (chez-ssl))) +``` + +### Existing API Contract (must preserve) + +The S3 API module calls these like: + +```scheme +;; Headers come as a nested list with :: separators: +;; (("Authorization" :: "AWS4-HMAC-SHA256 ...") :: ("Host" :: "bucket.s3.amazonaws.com") ("x-amz-date" :: "20260306T...") ...) +;; The :: symbols are literal Scheme symbols used as separators. + +(http-get url 'headers: headers 'params: query) +(http-put url 'headers: headers 'params: query 'data: body-bytes) +(http-delete url 'headers: headers 'params: query) +(http-head url 'headers: headers 'params: query) +``` + +A request result is accessed via: + +```scheme +(request-status req) ;; -> integer (200, 403, etc.) +(request-text req) ;; -> string (response body as text) +(request-content req) ;; -> bytevector (response body as bytes) +(request-headers req) ;; -> alist of response headers +(request-close req) ;; -> void +``` + +### Important: `request-content` Must Return Raw Bytes + +For S3 `get-object`, the response body is a `.json.gz` file — binary gzip data. `request-content` must return the raw bytes, NOT text-decoded. `request-text` can be a UTF-8 decode of the body for text responses (XML, JSON). + +## Implementation + +### URL Parsing + +```scheme +;; Parse "https://bucket.s3.amazonaws.com/path/to/key?query=val" +;; into: host, port (443), path, query-string +(define (parse-url url) + ;; Return (values host port path) + ;; Strip "https://" prefix, split on first "/" + ...) +``` + +### Header Flattening + +The S3 API passes headers in a peculiar nested format with `::` symbols: + +```scheme +;; Input: (("Authorization" :: "AWS4-...") :: ("Host" :: "bucket.s3.amazonaws.com") ...) +;; This is a cons-tree with :: as separator symbols mixed in. +;; Must flatten to: (("Authorization" . "AWS4-...") ("Host" . "bucket.s3.amazonaws.com") ...) +``` + +Write a `flatten-request-headers` function that: +1. Walks the nested list +2. Skips `::` symbols +3. Extracts `(name :: value)` triples into `(name . value)` pairs + +### Query String Building + +The `'params:` keyword receives a query as a list of `(key :: value)` triples: + +```scheme +;; Input: (("list-type" :: "2") ("prefix" :: "AWSLogs/...")) +;; Output: "list-type=2&prefix=AWSLogs%2F..." +``` + +Must URL-encode the values. Append to the URL path as `?query-string`. + +### HTTP/1.1 Request Construction + +``` +GET /path?query HTTP/1.1\r\n +Host: bucket.s3.amazonaws.com\r\n +Authorization: AWS4-HMAC-SHA256 ...\r\n +x-amz-date: 20260306T120000Z\r\n +x-amz-content-sha256: e3b0c44...\r\n +Connection: close\r\n +\r\n +``` + +For PUT/POST with body: + +``` +PUT /path HTTP/1.1\r\n +Host: ...\r\n +Content-Length: 12345\r\n +...\r\n +\r\n +<body bytes> +``` + +### Response Parsing + +Read the response in two phases: + +1. **Read headers**: Read bytes until `\r\n\r\n`. Parse the status line (`HTTP/1.1 200 OK`) and headers. + +2. **Read body**: Based on headers: + - If `Content-Length` is present: read exactly that many bytes + - If `Transfer-Encoding: chunked`: read chunked encoding (each chunk prefixed with hex length) + - Otherwise: read until connection close (EOF) + +**Chunked transfer encoding** is used by some AWS responses. Format: + +``` +1a\r\n <-- hex chunk size +<26 bytes of data>\r\n +0\r\n <-- zero-length chunk = end +\r\n +``` + +### Core Implementation Sketch + +```scheme +(define (do-request method url headers params data) + (let-values ([(host port path) (parse-url url)]) + (let* ([query-string (build-query-string params)] + [full-path (if (and query-string (> (string-length query-string) 0)) + (string-append path "?" query-string) + path)] + [flat-headers (flatten-request-headers headers)] + [conn (ssl-connect host port)] + [request-line (string-append method " " full-path " HTTP/1.1\r\n")] + [header-block (build-header-string flat-headers data)]) + ;; Send request + (ssl-write-string conn (string-append request-line header-block "\r\n")) + ;; Send body if present + (when data + (if (bytevector? data) + (ssl-write conn data) + (ssl-write-string conn data))) + ;; Read response + (let-values ([(status resp-headers body-bv) (read-response conn)]) + (ssl-close conn) + (make-request-result status resp-headers body-bv))))) +``` + +### Response Body Storage + +Store the body as a **bytevector** internally. This preserves binary data (gzip files from S3). + +```scheme +;; Internal: #(status headers body-bytevector) +(define (make-request-result status headers body-bv) + (vector status headers body-bv)) + +(define (request-status req) (vector-ref req 0)) +(define (request-headers req) (vector-ref req 1)) + +;; Body as raw bytes — critical for gzip data +(define (request-content req) (vector-ref req 2)) + +;; Body as text — for XML/JSON responses +(define (request-text req) + (utf8->string (vector-ref req 2))) + +(define (request-close req) (void)) +``` + +### Connection: close vs Keep-Alive + +For simplicity, start with `Connection: close` on every request. This means one TCP+TLS connection per request. + +**Future optimization**: For the S3 bulk download case (27,000+ sequential GETs to the same host), keep the connection alive and reuse it: + +```scheme +;; Connection pool: hostname:port -> ssl-connection +;; Reuse connections with Connection: keep-alive +;; Only close when the server closes or on error +``` + +This is an optimization — get it working with `Connection: close` first. + +## Edge Cases and Gotchas + +### 1. Header Format from S3 API + +The headers come as a deeply nested structure. Example actual value: + +```scheme +(("Authorization" :: "AWS4-HMAC-SHA256 Credential=AKIA.../20260306/us-east-1/s3/aws4_request, ...") + :: + ("Host" :: "mybucket.s3.amazonaws.com") + ("x-amz-date" :: "20260306T120000Z") + ("x-amz-content-sha256" :: "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855")) +``` + +Note the `::` as the second element of the outer list. Your flattener must handle this. + +### 2. Binary Response Bodies + +S3 `get-object` returns raw bytes (often gzip). The response body must be stored as a bytevector, not decoded as text. Only `request-text` should decode to UTF-8. + +### 3. Large Responses + +Some S3 responses can be megabytes. Read into a growing bytevector buffer, not a string accumulator. + +### 4. Chunked Transfer Encoding + +AWS S3 ListObjectsV2 responses may use chunked encoding. You must handle it. + +### 5. 100-continue + +For PUT requests, some servers send `100 Continue` before accepting the body. Handle by checking if the first status line is `100`, and if so, read another status line. + +### 6. Redirect (301/307) + +S3 may redirect if the bucket region doesn't match. For now, raise an error with the response body (which contains the correct endpoint). The S3 API layer already handles region selection. + +## Testing + +```scheme +;; Test 1: Simple GET +(let ([req (http-get "https://example.com/" 'headers: '() 'params: #f)]) + (assert (= (request-status req) 200)) + (assert (string-contains (request-text req) "Example Domain"))) + +;; Test 2: Binary response preservation +(let ([req (http-get "https://some-url/file.gz" 'headers: '() 'params: #f)]) + (let ([body (request-content req)]) + (assert (bytevector? body)) + ;; First two bytes should be gzip magic if the file is gzip + )) + +;; Test 3: S3-style headers +(let ([headers (list (list "Host" ':: "example.com") + ':: + (list "x-amz-date" ':: "20260306T000000Z"))]) + ;; Should flatten to (("Host" . "example.com") ("x-amz-date" . "20260306T000000Z")) + (let ([flat (flatten-request-headers headers)]) + (assert (= (length flat) 2)))) +``` + +## Integration into gherkin-kunabi + +Once `chez-ssl` and `chez-https` exist, the integration is: + +1. Replace `gherkin-aws/src/compat/request.sls` with the new `(compat request)` that imports `(chez-ssl)` and does native HTTPS +2. Add `(ssl-init!)` call in `kunabi-main.sls` at startup +3. Add `chez_ssl_shim.o` to the binary link step in `build-binary.ss` +4. Add `-lssl -lcrypto` to the linker flags (already linking other system libs) +5. **No changes needed** to `s3-api.sls`, `s3-objects.sls`, or `kunabi-loader.sls` — the API is the same + +## Project Structure + +``` +chez-https/ +├── src/ +│ └── compat/ +│ └── request.sls # Drop-in replacement for the curl-based version +├── tests/ +│ └── https-test.ss +├── Makefile +└── README.md +``` + +Or this could be part of `chez-ssl` itself as a higher-level module: + +``` +chez-ssl/ +├── chez_ssl_shim.c +├── src/ +│ ├── chez-ssl.sls # Low-level TLS transport +│ └── chez-https.sls # HTTP/1.1 client built on chez-ssl +├── tests/ +│ ├── ssl-test.ss +│ └── https-test.ss +├── Makefile +└── README.md +``` + +## Summary of What's Needed + +| Component | What | Complexity | +|-----------|------|------------| +| TCP connect | `socket()` + `getaddrinfo()` + `connect()` | Simple C | +| TLS handshake | OpenSSL `SSL_CTX_new` / `SSL_connect` with SNI | Medium C | +| TLS read/write | `SSL_read` / `SSL_write` with partial-write handling | Simple C | +| URL parsing | Split `https://host/path` | Simple Scheme | +| Header flattening | Walk nested `(name :: value)` lists | Medium Scheme | +| Query string | URL-encode and join `(key :: value)` pairs | Simple Scheme | +| HTTP request building | Format request line + headers + body | Simple Scheme | +| HTTP response parsing | Parse status line, headers, body (Content-Length or chunked) | Medium Scheme | +| Chunked decoding | Read hex-length prefixed chunks | Medium Scheme | new file mode 100644 --- /dev/null +++ b/src/chez-https.sls @@ -0,0 +1,484 @@ +;; chez-https — Native HTTP/1.1 client over TLS for Chez Scheme +;; +;; Dependencies: +;; chez-ssl — https://github.com/ober/chez-ssl +;; chez-zlib — https://github.com/ober/chez-zlib (optional, for gzip content) +;; +;; Provides the same API as (compat request) for drop-in replacement. + +(library (chez-https) + (export + ;; HTTP client API + http-get http-post http-put http-delete http-head + ;; Response accessors + request-status request-text request-content + request-headers request-header request-close + ;; Utilities + parse-url flatten-request-headers build-query-string url-encode) + (import (chezscheme) (chez-ssl)) + + ;; ================================================================ + ;; String utilities + ;; ================================================================ + + (define (string-prefix? prefix str) + (let ([plen (string-length prefix)] + [slen (string-length str)]) + (and (>= slen plen) + (string=? prefix (substring str 0 plen))))) + + (define (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))])))) + + (define (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))])))) + + (define (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))))) + + (define (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))) + + (define (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))))))) + + (define (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)])))) + + ;; ================================================================ + ;; Bytevector utilities + ;; ================================================================ + + (define (subbytevector bv start end) + (let ([result (make-bytevector (- end start))]) + (bytevector-copy! bv start result 0 (- end start)) + result)) + + (define (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))))))))) + + (define (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)))))) + + (define (read-bv-line bv start len) + ;; Read line from bytevector terminated by \r\n. + ;; Returns (values line-string position-after-crlf) + (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))]))) + + ;; ================================================================ + ;; URL encoding (RFC 3986) + ;; ================================================================ + + (define hex-chars "0123456789ABCDEF") + + (define (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)) ; A-Z + (and (fx>= b 97) (fx<= b 122)) ; a-z + (and (fx>= b 48) (fx<= b 57)) ; 0-9 + (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 #xf)) out))))]))) + str) + (get-output-string out))) + + ;; ================================================================ + ;; URL parsing + ;; ================================================================ + + (define (parse-url url) + ;; Returns (values host port path) + ;; path includes any query string already in the 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))) + + ;; ================================================================ + ;; Header flattening + ;; ================================================================ + + (define (flatten-request-headers hdrs) + ;; Input: (("Name" :: "Value") :: ("Name2" :: "Value2") ...) + ;; Output: (("Name" . "Value") ("Name2" . "Value2") ...) + ;; Handles the nested :: separator format used by the S3 API layer. + (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)) + ;; Recurse into nested structure + (loop (cdr items) + (append (reverse (flatten-request-headers item)) result))))] + [else (loop (cdr items) result)])))) + + ;; ================================================================ + ;; Query string building + ;; ================================================================ + + (define (build-query-string params) + ;; params uses the same (name :: value) format as headers. + (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) + "&")))) + + ;; ================================================================ + ;; Header lookup (case-insensitive) + ;; ================================================================ + + (define (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))])))) + + ;; ================================================================ + ;; HTTP request building + ;; ================================================================ + + (define (build-request method path host headers body-bv) + (let ([out (open-output-string)]) + (put-string out method) + (put-string out " ") + (put-string out path) + (put-string out " HTTP/1.1\r\n") + ;; Host header (unless user provided one) + (unless (header-assoc "Host" headers) + (put-string out "Host: ") + (put-string out host) + (put-string out "\r\n")) + ;; User-supplied headers + (for-each + (lambda (h) + (put-string out (car h)) + (put-string out ": ") + (put-string out (cdr h)) + (put-string out "\r\n")) + headers) + ;; Content-Length for requests with body + (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")) + ;; Connection: close (first version; keep-alive is a future optimization) + (put-string out "Connection: close\r\n") + (put-string out "\r\n") + (get-output-string out))) + + ;; ================================================================ + ;; Response parsing + ;; ================================================================ + + (define (parse-status-line line) + ;; "HTTP/1.1 200 OK" -> 200 + (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))))) + + (define (parse-headers lines) + ;; Parse header lines into alist with lowercase keys. + (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)))))) + + (define (header-value headers name) + (let ([pair (assoc name headers)]) + (and pair (cdr pair)))) + + (define (chunked-encoding? headers) + (let ([te (header-value headers "transfer-encoding")]) + (and te (string-contains (string-downcase te) "chunked") #t))) + + ;; ================================================================ + ;; Chunked transfer decoding + ;; ================================================================ + + (define (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)]) + ;; Chunk size may have extensions after semicolon + (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) + ;; Truncated final chunk — use what we have + (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))]))))))) + + ;; ================================================================ + ;; SSL auto-initialization + ;; ================================================================ + + (define *ssl-initialized* #f) + + (define (ensure-ssl-init!) + (unless *ssl-initialized* + (ssl-init!) + (set! *ssl-initialized* #t))) + + ;; ================================================================ + ;; Response reading + ;; ================================================================ + + (define (read-response conn) + ;; With Connection: close, ssl-read-all reads the entire response. + (let* ([raw (ssl-read-all conn)] + [len (bytevector-length raw)]) + (let loop ([offset 0]) + (let ([sep (find-crlfcrlf raw len offset)]) + (unless sep + (error 'read-response + "malformed HTTP response: no header terminator found" + (if (< len 500) (utf8->string raw) "<response too large to display>"))) + (let* ([header-str (utf8->string (subbytevector raw offset sep))] + [body-start (+ sep 4)] + [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) + ;; Skip "100 Continue" and parse the real response + (loop body-start) + (let* ([raw-body (if (< body-start len) + (subbytevector raw body-start len) + (make-bytevector 0))] + [body (if (chunked-encoding? headers) + (decode-chunked raw-body) + raw-body)]) + (values status headers body))))))))) + + ;; ================================================================ + ;; Request result accessors + ;; ================================================================ + + (define (make-request-result status headers body-bv) + (vector status headers body-bv)) + + (define (request-status req) (vector-ref req 0)) + (define (request-headers req) (vector-ref req 1)) + (define (request-content req) (vector-ref req 2)) + + (define (request-text req) + (let ([body (vector-ref req 2)]) + (if (= (bytevector-length body) 0) + "" + (utf8->string body)))) + + (define (request-header req name) + (let ([pair (assoc (string-downcase name) (vector-ref req 1))]) + (and pair (cdr pair)))) + + (define (request-close req) (void)) + + ;; ================================================================ + ;; Keyword argument parsing + ;; ================================================================ + + (define (parse-keyword-args args) + ;; Parse ('headers: val 'params: val 'data: val) + ;; Returns (values headers params data) + (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)])))))) + + ;; ================================================================ + ;; Core request function + ;; ================================================================ + + (define (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)])] + [request-str (build-request method full-path host flat-headers body-bv)] + [conn (ssl-connect host port)]) + (dynamic-wind + void + (lambda () + (ssl-write-string conn request-str) + (when body-bv (ssl-write conn body-bv)) + (let-values ([(status resp-headers body) (read-response conn)]) + (make-request-result status resp-headers body))) + (lambda () + (guard (e [#t (void)]) + (ssl-close conn))))))) + + ;; ================================================================ + ;; Public API + ;; ================================================================ + + (define (http-get url . args) + (let-values ([(headers params data) (parse-keyword-args args)]) + (do-request "GET" url headers params #f))) + + (define (http-post url . args) + (let-values ([(headers params data) (parse-keyword-args args)]) + (do-request "POST" url headers params data))) + + (define (http-put url . args) + (let-values ([(headers params data) (parse-keyword-args args)]) + (do-request "PUT" url headers params data))) + + (define (http-delete url . args) + (let-values ([(headers params data) (parse-keyword-args args)]) + (do-request "DELETE" url headers params #f))) + + (define (http-head url . args) + (let-values ([(headers params data) (parse-keyword-args args)]) + (do-request "HEAD" url headers params #f))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/tests/https-test.ss @@ -0,0 +1,188 @@ +#!/usr/bin/env scheme-script +;; chez-https test suite + +(import (chezscheme) (chez-https)) + +(define pass-count 0) +(define fail-count 0) + +(define (test name thunk) + (guard (e [#t (set! fail-count (+ fail-count 1)) + (display "FAIL: ") (display name) (newline) + (display " ") (display (condition-message e)) (newline)]) + (thunk) + (set! pass-count (+ pass-count 1)) + (display "PASS: ") (display name) (newline))) + +(define (assert-equal actual expected msg) + (unless (equal? actual expected) + (error 'assert-equal msg actual expected))) + +(define (string-contains? haystack needle) + (let ([hlen (string-length haystack)] + [nlen (string-length needle)]) + (let loop ([i 0]) + (cond + [(> (+ i nlen) hlen) #f] + [(string=? needle (substring haystack i (+ i nlen))) #t] + [else (loop (+ i 1))])))) + +;; ================================================================ +;; Unit tests — no network required +;; ================================================================ + +(display "--- Unit Tests ---\n") + +;; URL parsing +(test "parse-url: basic https" + (lambda () + (let-values ([(host port path) (parse-url "https://example.com/path/to/resource")]) + (assert-equal host "example.com" "host") + (assert-equal port 443 "port") + (assert-equal path "/path/to/resource" "path")))) + +(test "parse-url: custom port" + (lambda () + (let-values ([(host port path) (parse-url "https://example.com:8443/path")]) + (assert-equal host "example.com" "host") + (assert-equal port 8443 "port") + (assert-equal path "/path" "path"))))