summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--web/socket/client.scm45
-rw-r--r--web/socket/frame.scm3
2 files changed, 27 insertions, 21 deletions
diff --git a/web/socket/client.scm b/web/socket/client.scm
index 2017ab8..6561c26 100644
--- a/web/socket/client.scm
+++ b/web/socket/client.scm
@@ -1,6 +1,7 @@
;;; guile-websocket --- WebSocket client/server
;;; Copyright © 2016 David Thompson <davet@gnu.org>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2023 Andrew Whatson <whatson@tailcall.au>
;;;
;;; This file is part of guile-websocket.
;;;
@@ -30,6 +31,7 @@
#:use-module (rnrs io ports)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
+ #:use-module (web client)
#:use-module (web request)
#:use-module (web response)
#:use-module (web uri)
@@ -66,21 +68,22 @@ scheme."
(unencrypted-websocket-scheme? uri))
(not (uri-fragment uri))))
-(define (make-client-socket uri)
- "Connect a socket to the remote resource described by URI."
- (let* ((port (uri-port uri))
- (info (car (getaddrinfo (uri-host uri)
- (if port
- (number->string port)
- (symbol->string (uri-scheme uri)))
- (if port
- AI_NUMERICSERV
- 0))))
- (s (with-fluids ((%default-port-encoding #f))
- (socket (addrinfo:fam info) SOCK_STREAM IPPROTO_IP))))
- ;; TODO: Configure I/O buffering?
- (connect s (addrinfo:addr info))
- s))
+(define (make-client-socket uri verify-certificate?)
+ "Connect a socket to the remote resource described by URI.
+When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
+ ;; A ws(s) socket is equivalent to a http(s) socket; pretend to have
+ ;; a http uri and let guile's (web client) do the heavy lifting.
+ (let ((uri* (build-uri (match (uri-scheme uri)
+ ('wss 'https)
+ ('ws 'http))
+ #:userinfo (uri-userinfo uri)
+ #:host (uri-host uri)
+ #:port (uri-port uri)
+ #:path (uri-path uri)
+ #:query (uri-query uri)
+ #:fragment (uri-fragment uri)
+ #:validate? #t)))
+ (open-socket-for-uri uri* #:verify-certificate? verify-certificate?)))
(define-record-type <websocket>
(%make-websocket uri socket entropy-port state)
@@ -134,8 +137,9 @@ KEY."
(define (handshake ws)
"Perform the WebSocket handshake for the client WS."
(let ((key (generate-client-key ws)))
- (write-request (make-handshake-request (websocket-uri ws) key)
- (websocket-socket ws))
+ (let ((request (make-handshake-request (websocket-uri ws) key)))
+ (write-request request (websocket-socket ws))
+ (force-output (websocket-socket ws)))
(let* ((response (read-response (websocket-socket ws)))
(headers (response-headers response))
(upgrade (assoc-ref headers 'upgrade))
@@ -163,15 +167,16 @@ current system."
(const #f)
(const #t)) "r")))
-(define (make-websocket uri-or-string)
+(define* (make-websocket uri-or-string #:key (verify-certificate? #t))
"Create and establish a new WebSocket connection for the remote
-resource described by URI-OR-STRING."
+resource described by URI-OR-STRING. When VERIFY-CERTIFICATE? is
+true, verify HTTPS server certificates."
(let ((uri (match uri-or-string
((? uri? uri) uri)
((? string? str) (string->uri str)))))
(if (websocket-uri? uri)
(let ((ws (%make-websocket uri
- (make-client-socket uri)
+ (make-client-socket uri verify-certificate?)
(open-entropy-port)
'connecting)))
(handshake ws)
diff --git a/web/socket/frame.scm b/web/socket/frame.scm
index f54f016..f3709f6 100644
--- a/web/socket/frame.scm
+++ b/web/socket/frame.scm
@@ -372,4 +372,5 @@ MASKING-KEY."
(when mask (put-bytevector port mask))
;; Write data, potentially masked.
- (put-bytevector port (if mask (masked-data mask data) data))))
+ (put-bytevector port (if mask (masked-data mask data) data))
+ (force-output port)))