;;; guile-websocket --- WebSocket client/server ;;; Copyright © 2016 David Thompson ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen ;;; Copyright © 2023 Andrew Whatson ;;; ;;; This file is part of guile-websocket. ;;; ;;; Guile-websocket is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU Lesser General Public License as ;;; published by the Free Software Foundation; either version 3 of the ;;; License, or (at your option) any later version. ;;; ;;; Guile-websocket is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Lesser General Public License for more details. ;;; ;;; You should have received a copy of the GNU Lesser General Public ;;; License along with guile-websocket. If not, see ;;; . ;;; Commentary: ;; ;; WebSocket client. ;; ;;; Code: (define-module (web socket client) #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #: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) #:use-module (web socket base64) #:use-module (web socket frame) #:use-module (web socket utils) #:export (make-websocket websocket? websocket-uri websocket-socket websocket-state websocket-connecting? websocket-open? websocket-closing? websocket-closed? close-websocket websocket-send websocket-receive)) ;; See Section 3 - WebSocket URIs (define (encrypted-websocket-scheme? uri) "Return #t if the scheme for URI is 'wss', the secure WebSocket scheme." (eq? (uri-scheme uri) 'wss)) (define (unencrypted-websocket-scheme? uri) "Return #t if the scheme for URI is 'ws', the insecure WebSocket scheme." (eq? (uri-scheme uri) 'ws)) (define (websocket-uri? uri) "Return #t if URI is a valid WebSocket URI." (and (or (encrypted-websocket-scheme? uri) (unencrypted-websocket-scheme? uri)) (not (uri-fragment uri)))) (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 (%make-websocket uri socket entropy-port state) websocket? (uri websocket-uri) (socket websocket-socket) (entropy-port websocket-entropy-port) (state websocket-state set-websocket-state!)) (define (display-websocket ws port) (format port "#" (uri->string (websocket-uri ws)) (websocket-state ws))) (set-record-type-printer! display-websocket) (define (websocket-connecting? ws) "Return #t if the WebSocket WS is in the connecting state." (eq? (websocket-state ws) 'connecting)) (define (websocket-open? ws) "Return #t if the WebSocket WS is in the open state." (eq? (websocket-state ws) 'open)) (define (websocket-closing? ws) "Return #t if the WebSocket WS is in the closing state." (eq? (websocket-state ws) 'closing)) (define (websocket-closed? ws) "Return #t if the WebSocket WS is in the closed state." (eq? (websocket-state ws) 'closed)) (define (generate-client-key ws) "Return a random, base64 encoded nonce using the entropy source of WS." (base64-encode (get-bytevector-n (websocket-entropy-port ws) 16))) ;; See Section 4.1 - Client Requirements (define (make-handshake-request uri key) "Create an HTTP request for initiating a WebSocket connection with the remote resource described by URI, using a randomly generated nonce KEY." (let ((headers `((host . (,(uri-host uri) . #f)) (upgrade . ("WebSocket")) (connection . (upgrade)) (sec-websocket-key . ,key) (sec-websocket-version . "13")))) (build-request uri #:method 'GET #:headers headers))) (define (handshake ws) "Perform the WebSocket handshake for the client WS." (let ((key (generate-client-key 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)) (connection (assoc-ref headers 'connection)) (accept (assoc-ref headers 'sec-websocket-accept))) ;; Validate the handshake. (if (and (= (response-code response) 101) (string-ci=? (car upgrade) "websocket") (equal? connection '(upgrade)) (string=? (string-trim-both accept) (make-accept-key key))) (set-websocket-state! ws 'open) (begin (close-websocket ws) (error "websocket handshake failed" (websocket-uri ws))))))) (define (open-entropy-port) "Return an open input port to a reliable source of entropy for the current system." (if (file-exists? "/dev/urandom") (open-input-file "/dev/urandom") ;; XXX: This works as a fall back but this isn't exactly a ;; reliable source of entropy. (make-soft-port (vector (const #f) (const #f) (const #f) (lambda _ (let ((r (random 256))) (integer->char r))) (const #f) (const #t)) "r"))) (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. 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 verify-certificate?) (open-entropy-port) 'connecting))) (handshake ws) ws) (error "not a websocket uri" uri)))) (define* (close-websocket ws #:key (timeout 1)) "Close the WebSocket connection for the client WS, waiting up to TIMEOUT seconds (default 1 second) for a graceful shutdown." (let ((socket (websocket-socket ws))) (set-websocket-state! ws 'closing) (write-frame (make-close-frame (make-bytevector 0)) socket) ;; Per section 5.5.1 , wait for the server to close the connection ;; for a reasonable amount of time. (read-close-frame socket #:timeout timeout) (close-port socket) (close-port (websocket-entropy-port ws)) (set-websocket-state! ws 'closed) *unspecified*)) (define (generate-masking-key ws) "Create a new masking key using the entropy source of WS." ;; Masking keys are 32 bits long. (get-bytevector-n (websocket-entropy-port ws) 4)) (define (websocket-send ws data) "Send DATA, a string or bytevector, to the server that WS is connected to." ;; TODO: Send frames over some threshold in fragments. (write-frame (make-text-frame data (generate-masking-key ws)) (websocket-socket ws))) (define* (websocket-receive ws #:key timeout) "Read data from the server that WS is connected to. Returns a string if text data was received, a bytevector if binary data was received, a pair of (code . reason) if the WebSocket was closed, or #f if TIMEOUT seconds elapsed without receiving a data frame." (let ((socket (websocket-socket ws))) ;; For server initiated disconnects and timeouts. (define (maybe-close) (when (port-closed? socket) ;; EOF - clean up the websocket. (close-port (websocket-entropy-port ws)) (set-websocket-state! ws 'closed))) (match (read-data-frame socket #:timeout timeout) (#f ; timeout (maybe-close) #f) ((? close-frame? frame) (maybe-close) (close-frame->status frame)) ((? binary-frame? frame) (frame-data frame)) ((? text-frame? frame) (text-frame->string frame)))))