1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
|
;;; 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.
;;;
;;; 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
;;; <http://www.gnu.org/licenses/>.
;;; 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 <websocket>
(%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 "#<websocket ~a ~a>"
(uri->string (websocket-uri ws))
(websocket-state ws)))
(set-record-type-printer! <websocket> 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)
"Close the WebSocket connection for the client WS."
(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.
(let loop ()
(match (select #() (vector socket) #() 1) ; 1 second timeout
((#() #(socket) #()) ; there is output to read
(unless (port-eof? socket)
(read-frame socket) ; throw it away
(loop)))))
(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)
"Read a response from the server that WS is connected to."
;; TODO: Handle fragmented frames and control frames.
(let ((frame (read-frame (websocket-socket ws))))
(if (binary-frame? frame)
(frame-data frame)
(text-frame->string frame))))
|
