From 9328ad94443380f656bd8f11cedd9e8db164ce54 Mon Sep 17 00:00:00 2001
From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Mon, 22 Oct 2018 14:30:49 -0700
Subject: [PATCH] Fix http-get using binary IO and new
 open-binary-tcp-stream-socket.

---
 src/runtime/http-client.scm     |  12 +--
 src/runtime/http-io.scm         | 110 ++++++++++++++------------
 src/runtime/http-syntax.scm     | 133 ++++++++++++++++++++------------
 src/runtime/rfc2822-headers.scm |  44 +++++++++++
 src/runtime/runtime.pkg         |   4 +
 src/runtime/socket.scm          |  42 +++++++++-
 6 files changed, 234 insertions(+), 111 deletions(-)

diff --git a/src/runtime/http-client.scm b/src/runtime/http-client.scm
index 2122d011a..0b6a83e80 100644
--- a/src/runtime/http-client.scm
+++ b/src/runtime/http-client.scm
@@ -30,13 +30,13 @@ USA.
 (declare (usual-integrations))
 
 (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)))
@@ -47,9 +47,9 @@ USA.
 
 (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)))
diff --git a/src/runtime/http-io.scm b/src/runtime/http-io.scm
index 94fa33820..a1fae22a3 100644
--- a/src/runtime/http-io.scm
+++ b/src/runtime/http-io.scm
@@ -149,76 +149,91 @@ USA.
 
 ;;;; 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))))
 
 ;;;; 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)
@@ -233,8 +248,7 @@ USA.
 				 (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)
@@ -259,14 +273,13 @@ USA.
 	   (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)))))
@@ -274,8 +287,7 @@ USA.
 		 (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)))
@@ -284,16 +296,15 @@ USA.
       (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)
@@ -302,7 +313,7 @@ USA.
 	 (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)))
@@ -313,17 +324,16 @@ USA.
        (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)
diff --git a/src/runtime/http-syntax.scm b/src/runtime/http-syntax.scm
index cd28572d3..b6c5ab1c6 100644
--- a/src/runtime/http-syntax.scm
+++ b/src/runtime/http-syntax.scm
@@ -88,14 +88,23 @@ USA.
   (every (lambda (pred) (pred object))
 	 preds))
 
+(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))
@@ -115,7 +124,9 @@ USA.
     (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))))
 
@@ -143,7 +154,9 @@ USA.
 		     (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)))))))
 
@@ -194,10 +207,10 @@ USA.
 	       (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))
@@ -221,7 +234,7 @@ USA.
 		    (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))
 
 ;;;; Headers
 
@@ -245,9 +258,10 @@ USA.
     (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)
@@ -294,7 +308,7 @@ USA.
 (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)
@@ -317,9 +331,9 @@ USA.
 (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)))
@@ -327,12 +341,12 @@ USA.
 	((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)
@@ -345,9 +359,9 @@ USA.
 	      (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))
 
 ;;;; Header I/O
 
@@ -398,13 +412,19 @@ USA.
 	      (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))
 
 ;;;; Header element types
 
@@ -571,7 +591,7 @@ USA.
 		  exact-nonnegative-integer?))
 
 (define write-range
-  (pair-writer write #\- write))
+  (pair-writer write-object #\- write-object))
 
 (define (lp:numeric-token radix)
   (list-parser
@@ -586,7 +606,7 @@ USA.
 
 (define (write-opt-decimal n port)
   (if n
-      (write n port)))
+      (write-object n port)))
 
 (define lp:mime-type
   (list-parser
@@ -608,7 +628,10 @@ USA.
        (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
@@ -632,7 +655,7 @@ USA.
 		  (opt-predicate exact-nonnegative-integer?)))
 
 (define write-hostport
-  (pair-writer write-string
+  (pair-writer write-ascii
 	       #\:
 	       (opt-writer write)))
 
@@ -674,7 +697,7 @@ USA.
 (define write-entity-tag
   (pair-writer (lambda (weak? port)
 		 (if weak?
-		     (write-string "W/" port)))
+		     (write-ascii "W/" port)))
 	       #f
 	       write-quoted-string))
 
@@ -755,9 +778,9 @@ USA.
 		  (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
@@ -777,9 +800,16 @@ USA.
 	(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))
 
 ;;;; Tokenization
 
@@ -1149,10 +1179,10 @@ USA.
   (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"
@@ -1233,7 +1263,7 @@ USA.
 (define-header "Max-Forwards"
   (tokenized-parser lp:decimal)
   exact-nonnegative-integer?
-  write)
+  write-object)
 
 #;
 (define-header "Proxy-Authorization"
@@ -1266,7 +1296,7 @@ USA.
   (lambda (value)
     (and (uri? value)
 	 (not (uri-fragment value))))
-  write-uri)
+  write-ascii-uri)
 
 (define-comma-list-header "TE"
   (list-parser
@@ -1299,7 +1329,7 @@ USA.
 (define-header "Age"
   (tokenized-parser lp:decimal)
   exact-nonnegative-integer?
-  write)
+  write-object)
 
 (define-header "ETag"
   (tokenized-parser lp:entity-tag)
@@ -1309,7 +1339,7 @@ USA.
 (define-header "Location"
   (direct-parser parse-absolute-uri)
   absolute-uri?
-  write-uri)
+  write-ascii-uri)
 #;
 (define-header "Proxy-Authenticate"
   (tokenized-parser
@@ -1323,7 +1353,7 @@ USA.
     (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)
@@ -1349,7 +1379,7 @@ USA.
 (define-comma-list-header "Allow"
   lp:token-string
   http-token-string?
-  write-string)
+  write-ascii)
 
 (define-comma-list+-header "Content-Encoding"
   lp:token
@@ -1364,7 +1394,7 @@ USA.
 (define-header "Content-Length"
   (tokenized-parser lp:decimal)
   exact-nonnegative-integer?
-  write)
+  write-object)
 
 (define-header "Content-Location"
   (direct-parser
@@ -1374,7 +1404,7 @@ USA.
   (lambda (value)
     (and (uri? value)
 	 (not (uri-fragment value))))
-  write-uri)
+  write-ascii-uri)
 
 (define-header "Content-MD5"
   (lambda (string win lose)
@@ -1387,7 +1417,7 @@ USA.
     (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)))
 
 (define-header "Content-Range"
   (tokenized-parser
@@ -1410,7 +1440,8 @@ USA.
 		 #\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
@@ -1419,7 +1450,7 @@ USA.
       (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
@@ -1432,7 +1463,7 @@ USA.
 	      write-http-date
 	      (lambda (value port)
 		value
-		(write-string "-1" port))))
+		(write-ascii "-1" port))))
 
 (define-header "Last-Modified"
   (direct-parser parser:http-date)
diff --git a/src/runtime/rfc2822-headers.scm b/src/runtime/rfc2822-headers.scm
index ccb2d3781..2c80b5bc6 100644
--- a/src/runtime/rfc2822-headers.scm
+++ b/src/runtime/rfc2822-headers.scm
@@ -152,6 +152,11 @@ USA.
 					     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)
@@ -175,6 +180,45 @@ USA.
 		       (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)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 27354714e..194e36535 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -4117,6 +4117,8 @@ USA.
 	  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
@@ -4124,7 +4126,9 @@ USA.
 	  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!)))
 
diff --git a/src/runtime/socket.scm b/src/runtime/socket.scm
index bdacb22eb..fa864e718 100644
--- a/src/runtime/socket.scm
+++ b/src/runtime/socket.scm
@@ -78,7 +78,12 @@ USA.
 (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
@@ -87,9 +92,19 @@ USA.
 		       ((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 ()
@@ -118,16 +133,30 @@ USA.
 		   (let loop () (do-test loop))
 		   (do-test (lambda () #f))))))))
     (and channel
-	 (make-socket-port channel caller))))
+	 (make-port channel caller))))
 
 (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)
@@ -157,6 +186,11 @@ USA.
 			 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
-- 
2.25.1