(declare (usual-integrations))
\f
(define (http-get uri headers)
- (http-client-exchange "GET" uri headers ""))
+ (http-client-exchange "GET" (->uri uri) headers (bytevector)))
(define (http-head uri headers)
- (http-client-exchange "HEAD" uri headers ""))
+ (http-client-exchange "HEAD" (->uri uri) headers (bytevector)))
(define (http-post uri headers body)
- (http-client-exchange "POST" uri headers body))
+ (http-client-exchange "POST" (->uri uri) headers body))
(define (http-client-exchange method uri headers body)
(let ((request (http-client-request method uri headers body)))
(define (call-with-http-client-socket uri callee)
(let ((port
- (let ((authority (uri-authority uri)))
- (open-tcp-stream-socket (uri-authority-host authority)
- (or (uri-authority-port authority) 80)))))
+ (let ((auth (uri-authority uri)))
+ (open-binary-tcp-stream-socket (uri-authority-host auth)
+ (or (uri-authority-port auth) 80)))))
(let ((value (callee port)))
(close-port port)
value)))
\f
;;;; Output
-(define (%text-mode port)
- (port/set-coding port 'iso-8859-1)
- (port/set-line-ending port 'crlf))
-
-(define (%binary-mode port)
- (port/set-coding port 'binary)
- (port/set-line-ending port 'binary))
-
(define (write-http-request request port)
- (%text-mode port)
- (write-string (http-request-method request) port)
- (write-string " " port)
+ (write-ascii (http-request-method request) port)
+ (write-u8 (char->integer #\space) port)
(let ((uri (http-request-uri request)))
(cond ((uri? uri)
- (write-uri uri port))
+ (write-ascii (call-with-output-string
+ (lambda (out) (write-uri uri out)))
+ port))
((uri-authority? uri)
- (write-uri-authority uri port))
+ (write-ascii (call-with-output-string
+ (lambda (out) (write-uri-authority uri out)))
+ port))
((eq? uri '*)
- (write-char #\* port))
+ (write-u8 (char->integer #\*) port))
(else
(error "Ill-formed HTTP request:" request))))
(if (http-request-version request)
(begin
- (write-string " " port)
+ (write-u8 (char->integer #\space) port)
(write-http-version (http-request-version request) port)
- (newline port)
+ (write-u8 (char->integer #\return) port)
+ (write-u8 (char->integer #\linefeed) port)
(write-http-headers (http-request-headers request) port)
- (%binary-mode port)
- (write-body (http-request-body request) port))
+ (write-bytevector (http-request-body request) port))
(begin
(newline port)))
(flush-output-port port))
+(define (write-ascii string port)
+ (write-bytevector (string->utf8 string) port))
+
(define (write-http-response response port)
(if (http-response-version response)
(begin
- (%text-mode port)
(write-http-version (http-response-version response) port)
- (write-string " " port)
- (write (http-response-status response) port)
- (write-string " " port)
- (write-string (http-response-reason response) port)
+ (write-u8 (char->integer #\space) port)
+ (write-ascii (write-to-string (http-response-status response)) port)
+ (write-u8 (char->integer #\space) port)
+ (write-ascii (http-response-reason response) port)
(newline port)
(write-http-headers (http-response-headers response) port)))
- (%binary-mode port)
- (write-body (http-response-body response) port)
+ (write-bytevector (http-response-body response) port)
(flush-output-port port))
-
-(define (write-body body port)
- (let ((n (bytevector-length body)))
- (do ((i 0 (fix:+ i 1)))
- ((not (fix:< i n)))
- (write-char (integer->char (bytevector-u8-ref body)) port))))
\f
;;;; Input
(define (read-simple-http-request port)
- (%text-mode port)
- (let ((line (read-line port)))
+ (let ((line (read-ascii-line port)))
(if (eof-object? line)
line
(make-simple-http-request
(parse-line parse-simple-request line "simple HTTP request")))))
+(define (read-ascii-line port)
+ (with-input-port-blocking-mode port 'blocking
+ (lambda ()
+ (let ((builder (string-builder)))
+ (let loop ()
+ (let ((byte (read-u8 port)))
+ (cond ((eof-object? byte)
+ (if (builder 'empty?)
+ byte
+ (builder)))
+ ((fix:= 13 byte)
+ (let ((line (builder)))
+ (if (fix:= 10 (peek-u8 port))
+ (read-u8 port)
+ (warn "Invalid line ending in header line:" line))
+ line))
+ ((fix:= 10 byte)
+ (let ((line (builder)))
+ (warn "Invalid line ending in header line:" line)
+ line))
+ ((and (fix:<= 32 byte) (fix:<= byte 126))
+ (builder (integer->char byte))
+ (loop))
+ (else
+ (warn "Illegal character in header line:" byte (builder))
+ (loop)))))))))
+
(define (read-simple-http-response port)
(make-simple-http-response (%read-all port)))
(define (read-http-request port)
- (%text-mode port)
- (let ((line (read-line port)))
+ (let ((line (read-ascii-line port)))
(if (eof-object? line)
line
(receive (method uri version)
(car b.t))))))))
(define (read-http-response request port)
- (%text-mode port)
- (let ((line (read-line port)))
+ (let ((line (read-ascii-line port)))
(if (eof-object? line)
#f
(receive (version status reason)
(and (not (default-object? v))
(assq 'chunked v)))
(let ((output (open-output-bytevector))
- (buffer (make-string #x1000)))
+ (buffer (make-bytevector #x1000)))
(let loop ()
(let ((n (%read-chunk-leader port)))
(if (> n 0)
(begin
(%read-chunk n buffer port output)
- (%text-mode port)
- (let ((line (read-line port)))
+ (let ((line (read-ascii-line port)))
(if (not (string-null? line))
(error "Missing CRLF after chunk data.")))
(loop)))))
(read-http-headers port))))))
(define (%read-chunk-leader port)
- (%text-mode port)
- (let ((line (read-line port)))
+ (let ((line (read-ascii-line port)))
(if (eof-object? line)
(error "Premature EOF in HTTP message body."))
(let ((v (parse-http-chunk-leader line)))
(car v))))
(define (%read-chunk n buffer port output)
- (%binary-mode port)
(let ((len (bytevector-length buffer)))
(let loop ((n n))
(if (> n 0)
- (let ((m (read-string! buffer port 0 (min n len))))
+ (let ((m (read-bytevector! buffer port 0 (min n len))))
(if (= m 0)
(error "Premature EOF in HTTP message body."))
(do ((i 0 (+ i 1)))
((not (< i m)))
- (write-u8 (char->integer (string-ref buffer i)) output))
+ (write-u8 (bytevector-u8-ref buffer i) output))
(loop (- n m)))))))
(define (%read-delimited-body headers port)
(list
(call-with-output-bytevector
(lambda (output)
- (%read-chunk n (make-string #x1000) port output)))))))
+ (%read-chunk n (make-bytevector #x1000) port output)))))))
(define (%read-terminal-body headers port)
(and (let ((h (http-header 'connection headers #f)))
(list (%read-all port))))
(define (%read-all port)
- (%binary-mode port)
(call-with-output-bytevector
(lambda (output)
- (let ((buffer (make-string #x1000)))
+ (let ((buffer (make-bytevector #x1000)))
(let loop ()
- (let ((n (read-string! buffer port)))
+ (let ((n (read-bytevector! buffer port)))
(if (> n 0)
(begin
(do ((i 0 (+ i 1)))
((not (< i n)))
- (write-u8 (char->integer (string-ref buffer i)) output))
+ (write-u8 (bytevector-u8-ref buffer i) output))
(loop)))))))))
(define (%no-read-body)
(every (lambda (pred) (pred object))
preds))
\f
+(define (->ascii string)
+ (string->utf8 string))
+
+(define (write-ascii string port)
+ (write-bytevector (->ascii string) port))
+
+(define (write-object value port)
+ (write-ascii (write-to-string value) port))
+
(define ((sep-list-writer sep write-elt) value port)
(if (pair? value)
- (begin
- (write-elt (car value) port)
- (for-each (lambda (elt)
- (display sep port)
- (write-elt elt port))
- (cdr value)))))
+ (let ((bytes (->ascii sep)))
+ (write-elt (car value) port)
+ (for-each (lambda (elt)
+ (write-bytevector bytes port)
+ (write-elt elt port))
+ (cdr value)))))
(define (comma-list-writer write-elt)
(sep-list-writer ", " write-elt))
(if write-car
(write-car (car value) port))
(if (and sep write-car write-cdr)
- (display sep port))
+ (if (char? sep)
+ (write-u8 (char->integer sep) port)
+ (write-ascii sep port)))
(if write-cdr
(write-cdr (cdr value) port))))
(cadr args))))
(if writer
(begin
- (if sep (display sep port))
+ (if sep (if (char? sep)
+ (write-u8 (char->integer sep) port)
+ (write-ascii sep port)))
(writer (vector-ref value i) port)))
(loop (cddr args) (+ i 1)))))))
(match (+ (char-set char-set:numeric))))))))
(define (write-http-version version port)
- (write-string "HTTP/" port)
- (write (car version) port)
- (write-string "." port)
- (write (cdr version) port))
+ (write-ascii "HTTP/" port)
+ (write-object (car version) port)
+ (write-u8 (char->integer #\.) port)
+ (write-object (cdr version) port))
(define-deferred http-version:1.0 (make-http-version 1 0))
(define-deferred http-version:1.1 (make-http-version 1 1))
(char-set char-set:numeric))))))
(define (write-http-status object port)
- (write-string (string-pad-left (number->string object) 3 #\0) port))
+ (write-ascii (string-pad-left (number->string object) 3 #\0) port))
\f
;;;; Headers
(if defn
(if ((hvdefn-predicate defn) value)
(%make-header name
- (call-with-output-string
- (lambda (port)
- ((hvdefn-writer defn) value port)))
+ (utf8->string
+ (call-with-output-bytevector
+ (lambda (port)
+ ((hvdefn-writer defn) value port))))
value)
(begin
(guarantee http-text? value 'make-http-header)
(define-guarantee http-token "HTTP token")
(define (write-http-token token port)
- (write-string (symbol->string token) port))
+ (write-ascii (symbol->string token) port))
(define (http-token-string? object)
(and (string? object)
(define-guarantee http-text "HTTP text")
(define (write-quoted-string string port)
- (write-char #\" port)
+ (write-u8 (char->integer #\") port)
(%write-with-quotations string char-set:http-qdtext port)
- (write-char #\" port))
+ (write-u8 (char->integer #\") port))
(define (%write-with-quotations string unquoted port)
(let ((n (string-length string)))
((not (fix:< i n)))
(let ((char (string-ref string i)))
(if (not (char-in-set? char unquoted))
- (write-char #\\ port))
- (write-char char port)))))
+ (write-u8 (char->integer #\\) port))
+ (write-u8 (char->integer char) port)))))
(define write-text
(alt-writer string-is-http-token?
- write-string
+ write-ascii
write-quoted-string))
(define (comment? string)
(else (loop level)))))))
(define (write-comment string port)
- (write-char #\( port)
+ (write-u8 (char->integer #\() port)
(%write-with-quotations string char-set:http-text port)
- (write-char #\) port))
+ (write-u8 (char->integer #\)) port))
\f
;;;; Header I/O
(let ((name (http-header-name header)))
(let ((defn (header-value-defn name)))
(if defn
- (write-string (hvdefn-name defn) port)
+ (write-ascii (hvdefn-name defn) port)
(write-http-token name port))))
- (write-string ": " port)
- (write-string (http-header-value header) port)
- (newline port))
+ (write-u8 (char->integer #\:) port)
+ (write-u8 (char->integer #\space) port)
+ (let ((value (http-header-value header)))
+ (if (bytevector? value)
+ (write-bytevector value port)
+ (write-ascii value port)))
+ (write-u8 (char->integer #\return) port)
+ (write-u8 (char->integer #\linefeed) port))
headers)
- (newline port))
+ (write-u8 (char->integer #\return) port)
+ (write-u8 (char->integer #\linefeed) port))
\f
;;;; Header element types
exact-nonnegative-integer?))
(define write-range
- (pair-writer write #\- write))
+ (pair-writer write-object #\- write-object))
\f
(define (lp:numeric-token radix)
(list-parser
(define (write-opt-decimal n port)
(if n
- (write n port)))
+ (write-object n port)))
(define lp:mime-type
(list-parser
(eqv? (decoded-time/zone value) 0)))
(define (write-http-date value port)
- (write-decoded-time-as-http value port))
+ (write-ascii (call-with-output-string
+ (lambda (out)
+ (write-decoded-time-as-http value out)))
+ port))
(define lp:hostport
(list-parser
(opt-predicate exact-nonnegative-integer?)))
(define write-hostport
- (pair-writer write-string
+ (pair-writer write-ascii
#\:
(opt-writer write)))
(define write-entity-tag
(pair-writer (lambda (weak? port)
(if weak?
- (write-string "W/" port)))
+ (write-ascii "W/" port)))
#f
write-quoted-string))
(opt-predicate http-token-string?)))
(define write-product
- (pair-writer write-string
+ (pair-writer write-ascii
#\/
- (opt-writer write-string)))
+ (opt-writer write-ascii)))
(define lp:product/comment-list
(list-parser
(begin
(write-elt (car value) port)
(for-each (lambda (elt)
- (write-char #\space port)
+ (write-u8 (char->integer #\space) port)
(write-elt elt port))
(cdr value))))))
+
+(define (write-ascii-uri value port)
+ (write-ascii (call-with-output-string (lambda (out) (write-uri value out)))
+ port))
+
+(define (write-ascii-mime-type mime-type port)
+ (write-ascii (mime-type->string mime-type) port))
\f
;;;; Tokenization
(pair-predicate (alt-predicate mime-type? http-token?)
accept-params?)
(value+params-writer (alt-writer mime-type?
- write-mime-type
+ write-ascii-mime-type
(lambda (value port)
(write-http-token value port)
- (write-string "/*" port)))
+ (write-ascii "/*" port)))
";"))
(define-comma-list+-header "Accept-Charset"
(define-header "Max-Forwards"
(tokenized-parser lp:decimal)
exact-nonnegative-integer?
- write)
+ write-object)
\f
#;
(define-header "Proxy-Authorization"
(lambda (value)
(and (uri? value)
(not (uri-fragment value))))
- write-uri)
+ write-ascii-uri)
(define-comma-list-header "TE"
(list-parser
(define-header "Age"
(tokenized-parser lp:decimal)
exact-nonnegative-integer?
- write)
+ write-object)
(define-header "ETag"
(tokenized-parser lp:entity-tag)
(define-header "Location"
(direct-parser parse-absolute-uri)
absolute-uri?
- write-uri)
+ write-ascii-uri)
#;
(define-header "Proxy-Authenticate"
(tokenized-parser
(alt parser:http-date
lp:decimal)))
(alt-predicate http-date? exact-nonnegative-integer?)
- (alt-writer http-date? write-http-date write))
+ (alt-writer http-date? write-http-date write-object))
(define-header "Server"
(tokenized-parser lp:product/comment-list)
(define-comma-list-header "Allow"
lp:token-string
http-token-string?
- write-string)
+ write-ascii)
(define-comma-list+-header "Content-Encoding"
lp:token
(define-header "Content-Length"
(tokenized-parser lp:decimal)
exact-nonnegative-integer?
- write)
+ write-object)
(define-header "Content-Location"
(direct-parser
(lambda (value)
(and (uri? value)
(not (uri-fragment value))))
- write-uri)
+ write-ascii-uri)
(define-header "Content-MD5"
(lambda (string win lose)
(and (bytevector? value)
(= (bytevector-length value) 16)))
(lambda (value port)
- (write-string (string-trim-right (encode-base64-bytes value)) port)))
+ (write-ascii (string-trim-right (encode-base64-bytes value)) port)))
\f
(define-header "Content-Range"
(tokenized-parser
#\space
(alt-predicate range? write-range write-*)
#\/
- (alt-predicate exact-nonnegative-integer? write write-*)))
+ (alt-predicate exact-nonnegative-integer?
+ write-object write-*)))
(define-header "Content-Type"
(tokenized-parser
(seq lp:mime-type
lp:parameters))))
(value+params-predicate mime-type?)
- (value+params-writer write-mime-type "; "))
+ (value+params-writer write-ascii-mime-type "; "))
(define-header "Expires"
(direct-parser
write-http-date
(lambda (value port)
value
- (write-string "-1" port))))
+ (write-ascii "-1" port))))
(define-header "Last-Modified"
(direct-parser parser:http-date)
end)))))))
(define (read-rfc2822-folded-line port)
+ (if (binary-input-port? port)
+ (read-rfc2822-folded-line* read-ascii-line peek-ascii-char port)
+ (read-rfc2822-folded-line* read-line peek-char port)))
+
+(define (read-rfc2822-folded-line* read-line peek-char port)
(let ((line (read-line port)))
(cond ((string-null? line)
#f)
(write-char #\space out)
(loop (read-line port)))))))))))
+(define (read-ascii-line port)
+ (with-input-port-blocking-mode port 'blocking
+ (lambda ()
+ (let ((builder (string-builder)))
+ (let loop ()
+ (let ((byte (read-u8 port)))
+ (cond ((eof-object? byte)
+ (if (builder 'empty?)
+ byte
+ (builder)))
+ ((fix:= 13 byte)
+ (let ((line (builder)))
+ (if (fix:= 10 (peek-u8 port))
+ (read-u8 port)
+ (parse-error port
+ "Invalid line ending:"
+ 'read-rfc2822-folded-line))
+ line))
+ ((fix:= 10 byte)
+ (let ((line (builder)))
+ (parse-error port
+ "Invalid line ending:"
+ 'read-rfc2822-folded-line)
+ line))
+ ((and (fix:<= 32 byte) (fix:<= byte 126))
+ (builder (integer->char byte))
+ (loop))
+ (else
+ (parse-error port
+ "Illegal character:"
+ 'read-rfc2822-folded-line)
+ (loop)))))))))
+
+(define (peek-ascii-char port)
+ (let ((byte (peek-u8 port)))
+ (if (eof-object? byte)
+ byte
+ (integer->char byte))))
+
(define (skip-wsp-left string start end)
(let loop ((i start))
(if (and (fix:< i end)
host-address-any
host-address-loopback
listen-tcp-server-socket
+ open-binary-tcp-stream-socket
+ open-binary-unix-stream-socket
open-tcp-server-socket
open-tcp-stream-socket
open-tcp-stream-socket-channel
open-unix-stream-socket
open-unix-stream-socket-channel
os/hostname
+ tcp-server-binary-connection-accept
tcp-server-connection-accept
+ unix-server-binary-connection-accept
unix-server-connection-accept)
(initialization (initialize-package!)))
(define (tcp-server-connection-accept server-socket block? peer-address)
(connection-accept (ucode-primitive new-tcp-server-connection-accept 3)
server-socket block? peer-address
- 'tcp-server-connection-accept))
+ make-socket-port 'tcp-server-connection-accept))
+
+(define (tcp-server-binary-connection-accept server-socket block? peer-address)
+ (connection-accept (ucode-primitive new-tcp-server-connection-accept 3)
+ server-socket block? peer-address
+ make-binary-socket-port 'tcp-server-connection-accept))
(define (unix-server-connection-accept server-socket block?)
(connection-accept (named-lambda (new-unix-server-connection-accept
((ucode-primitive new-unix-server-connection-accept 2)
socket pair))
server-socket block? #f
- 'unix-server-connection-accept))
+ make-socket-port 'unix-server-connection-accept))
-(define (connection-accept accept! server-socket block? peer-address caller)
+(define (unix-server-binary-connection-accept server-socket block?)
+ (connection-accept (named-lambda (new-unix-server-connection-accept
+ socket peer pair)
+ (declare (ignore peer))
+ ((ucode-primitive new-unix-server-connection-accept 2)
+ socket pair))
+ server-socket block? #f
+ make-binary-socket-port 'unix-server-connection-accept))
+
+(define (connection-accept accept! server-socket block? peer-address
+ make-port caller)
(let ((channel
(with-thread-events-blocked
(lambda ()
(let loop () (do-test loop))
(do-test (lambda () #f))))))))
(and channel
- (make-socket-port channel caller))))
+ (make-port channel caller))))
\f
(define (open-tcp-stream-socket host-name service)
(let ((channel (open-tcp-stream-socket-channel host-name service)))
(make-socket-port channel 'open-tcp-stream-socket)))
+(define (open-binary-tcp-stream-socket host-name service)
+ (let* ((channel (open-tcp-stream-socket-channel host-name service))
+ (port (make-binary-socket-port channel
+ 'open-binary-tcp-stream-socket)))
+ (set-port-property! port 'pathname (string host-name":"service))
+ port))
+
(define (open-unix-stream-socket pathname)
(let ((channel (open-unix-stream-socket-channel pathname)))
(make-socket-port channel 'open-unix-stream-socket)))
+(define (open-binary-unix-stream-socket pathname)
+ (let* ((channel (open-unix-stream-socket-channel pathname))
+ (port (make-binary-socket-port channel
+ 'open-binary-unix-stream-socket)))
+ (set-port-property! port 'pathname (string pathname))
+ port))
+
(define (open-tcp-stream-socket-channel host-name service)
(let ((host
(vector-ref (or (get-host-by-name host-name)
socket-port-type
caller))
+(define (make-binary-socket-port channel caller)
+ (make-binary-port (make-channel-input-source channel)
+ (make-channel-output-sink channel)
+ caller))
+
(define socket-port-type)
(define (initialize-package!)
(set! socket-port-type
projects / mit-scheme.git / commitdiff