From 2d1a0c7ace538146e2b841620779867aaec17753 Mon Sep 17 00:00:00 2001
From: Andrew Whatson <whatson@tailcall.au>
Date: Wed, 19 Apr 2023 23:11:48 +1000
Subject: client: Support secure websockets.

* web/socket/client.scm (make-client-socket): Add verify-certificate?
parameter.  Call open-socket-for-uri to create the socket.
(handshake): Flush the port after writing the request.
(make-websocket): Add #:verify-certificate? parameter.
* web/socket/frame.scm (write-frame): Flush the port after writing the
frame.
---
 web/socket/client.scm | 45 +++++++++++++++++++++++++--------------------
 web/socket/frame.scm  |  3 ++-
 2 files changed, 27 insertions(+), 21 deletions(-)

(limited to 'web')

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)))
-- 
cgit v1.2.3