1 ;;; guile-websocket --- WebSocket client/server
2 ;;; Copyright © 2016 David Thompson <davet@gnu.org>
3 ;;; Copyright © 2017 Christopher Allan Webber <cwebber@dustycloud.org>
4 ;;; Copyright © 2019, 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
6 ;;; This file is part of guile-websocket.
8 ;;; Guile-websocket is free software; you can redistribute it and/or modify
9 ;;; it under the terms of the GNU Lesser General Public License as
10 ;;; published by the Free Software Foundation; either version 3 of the
11 ;;; License, or (at your option) any later version.
13 ;;; Guile-websocket is distributed in the hope that it will be useful,
14 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 ;;; Lesser General Public License for more details.
18 ;;; You should have received a copy of the GNU Lesser General Public
19 ;;; License along with guile-websocket. If not, see
20 ;;; <http://www.gnu.org/licenses/>.
28 (define-module (8sync systems websocket client)
29 #:use-module (ice-9 match)
30 #:use-module (srfi srfi-26)
31 #:use-module (rnrs bytevectors)
32 #:use-module (rnrs io ports)
33 #:use-module (web request)
34 #:use-module (web response)
35 #:use-module (web uri)
36 #:use-module (oop goops)
38 #:use-module (8sync ports)
39 #:use-module (8sync contrib base64)
40 #:use-module (8sync systems websocket frame)
41 #:use-module (8sync systems websocket utils)
61 (define no-op (const #f))
63 (define-actor <websocket> (<actor>)
64 ((*init* websocket-init)
65 (close websocket-close)
67 (send websocket-send))
69 (state #:accessor .state #:init-value 'closed #:init-keyword #:state)
70 (socket #:accessor .socket #:init-value #f #:init-keyword #:socket)
71 (url #:getter .url #:init-value #f #:init-keyword #:url)
72 (uri #:accessor .uri #:init-value #f #:init-keyword #:uri)
73 (entropy-port #:accessor .entropy-port #:init-form (open-entropy-port))
75 (on-close #:init-keyword #:on-close
78 (on-error #:init-keyword #:on-error
81 (on-message #:init-keyword #:on-message
82 #:accessor .on-message)
83 (on-open #:init-keyword #:on-open
87 (define-method (websocket-close (websocket <websocket>) message)
88 (when (websocket-open? websocket)
89 (false-if-exception (close-port (.socket websocket)))
90 (set! (.state websocket) 'closed)
91 (false-if-exception ((.on-close websocket) websocket))
92 (set! (.socket websocket) #f)))
94 (define-method (websocket-open (websocket <websocket>) message uri-or-string)
95 (if (websocket-closed? websocket)
96 (let ((uri (match uri-or-string
98 ((? string? str) (string->uri str)))))
99 (if (websocket-uri? uri)
102 (set! (.uri websocket) uri)
103 (let ((sock (make-client-socket uri)))
104 (set! (.socket websocket) sock)
105 (handshake websocket)
106 (websocket-loop websocket message)))
108 ((.on-error websocket) websocket (format #f "open failed: ~s: ~s" uri-or-string args))))
109 ((.on-error websocket) websocket (format #f "not a websocket uri: ~s" uri-or-string))))
110 ((.on-error websocket) websocket (format #f "cannot open websocket in state: ~s" (.state websocket)))))
112 (define-method (websocket-send (websocket <websocket>) message data)
113 (catch #t ; expect: wrong-type-arg (open port), system-error
116 (cond ((string? data)
117 (make-text-frame data))
119 (make-binary-frame data)))
120 (.socket websocket)))
122 (unless (and (memq key '(system-error wrong-type-arg))
124 (((or "put-u8" "put-bytevector") arg ...) #t)
126 (apply throw key args))
127 (let ((message (format #f "~a: ~s" key args)))
128 ((.on-error websocket) websocket (format #f "send failed: ~s ~a\n" websocket message))
129 (websocket-close websocket message)))))
131 (define-method (websocket-init (websocket <websocket>) message)
132 (and=> (.url websocket) (cut websocket-open websocket message <>)))
134 (define-method (websocket-loop (websocket <websocket>) message)
136 (define (handle-data-frame type data)
137 ((.on-message websocket)
140 ('text (utf8->string data))
143 (define (read-frame-maybe)
144 (and (not (eof-object? (lookahead-u8 (.socket websocket))))
145 (read-frame (.socket websocket))))
148 (websocket-close websocket message))
150 ((.on-open websocket) websocket)
152 (let loop ((fragments '())
154 (let* ((socket (.socket websocket))
155 (frame (and (websocket-open? websocket)
156 (read-frame-maybe))))
158 ;; EOF - port is closed.
159 ;; @@: Sometimes the eof object appears here as opposed to
160 ;; at lookahead, but I'm not sure why
161 ((or (not frame) (eof-object? frame))
163 ;; Per section 5.4, control frames may appear interspersed
164 ;; along with a fragmented message.
165 ((close-frame? frame)
166 ;; Per section 5.5.1, echo the close frame back to the
167 ;; socket before closing the socket. The socket may no
168 ;; longer be listening.
170 (write-frame (make-close-frame (frame-data frame)) socket))
173 ;; Per section 5.5.3, a pong frame must include the exact
174 ;; same data as the ping frame.
175 (write-frame (make-pong-frame (frame-data frame)) socket)
176 (loop fragments type))
177 ((pong-frame? frame) ; silently ignore pongs
178 (loop fragments type))
179 ((first-fragment-frame? frame) ; begin accumulating fragments
180 (loop (list frame) (frame-type frame)))
181 ((final-fragment-frame? frame) ; concatenate all fragments
182 (handle-data-frame type (frame-concatenate
183 (reverse (cons frame fragments))))
185 ((fragment-frame? frame) ; add a fragment
186 (loop (cons frame fragments) type))
187 ((data-frame? frame) ; unfragmented data frame
188 (handle-data-frame (frame-type frame) (frame-data frame))
191 ;; See Section 3 - WebSocket URIs
192 (define (encrypted-websocket-scheme? uri)
193 "Return #t if the scheme for URI is 'wss', the secure WebSocket
195 (eq? (uri-scheme uri) 'wss))
197 (define (unencrypted-websocket-scheme? uri)
198 "Return #t if the scheme for URI is 'ws', the insecure WebSocket
200 (eq? (uri-scheme uri) 'ws))
202 (define (websocket-uri? uri)
203 "Return #t if URI is a valid WebSocket URI."
204 (and (or (encrypted-websocket-scheme? uri)
205 (unencrypted-websocket-scheme? uri))
206 (not (uri-fragment uri))))
208 (define (set-nonblocking! port)
209 (fcntl port F_SETFL (logior O_NONBLOCK (fcntl port F_GETFL)))
210 (setvbuf port 'block 1024))
212 (define (make-client-socket uri)
213 "Connect a socket to the remote resource described by URI."
214 (let* ((port (uri-port uri))
215 (info (car (getaddrinfo (uri-host uri)
217 (number->string port)
218 (symbol->string (uri-scheme uri)))
222 (sock (with-fluids ((%default-port-encoding #f))
223 (socket (addrinfo:fam info) SOCK_STREAM IPPROTO_IP))))
225 (set-nonblocking! sock)
226 ;; Disable buffering for websockets
229 ;; TODO: Configure I/O buffering?
230 (connect sock (addrinfo:addr info))
233 (define-method (write (o <websocket>) port)
234 (format port "#<websocket ~a ~a>"
238 (define-method (websocket-connecting? (websocket <websocket>))
239 "Return #t if WEBSOCKET is in the connecting state."
240 (eq? (.state websocket) 'connecting))
242 (define-method (websocket-open? (websocket <websocket>))
243 "Return #t if WEBSOCKET is in the open state."
244 (eq? (.state websocket) 'open))
246 (define-method (websocket-closing? (websocket <websocket>))
247 "Return #t if WEBSOCKET is in the closing state."
248 (eq? (.state websocket) 'closing))
250 (define-method (websocket-closed? (websocket <websocket>))
251 "Return #t if WEBSOCKET is in the closed state."
252 (eq? (.state websocket) 'closed))
254 (define-method (generate-client-key (websocket <websocket>))
255 "Return a random, base64 encoded nonce using the entropy source of
258 (get-bytevector-n (.entropy-port websocket) 16)))
260 ;; See Section 4.1 - Client Requirements
261 (define (make-handshake-request uri key)
262 "Create an HTTP request for initiating a WebSocket connection with
263 the remote resource described by URI, using a randomly generated nonce
265 (let ((headers `((host . (,(uri-host uri) . #f))
266 (upgrade . ("WebSocket"))
267 (connection . (upgrade))
268 (sec-websocket-key . ,key)
269 (sec-websocket-version . "13"))))
270 (build-request uri #:method 'GET #:headers headers)))
272 (define-method (handshake (websocket <websocket>))
273 "Perform the WebSocket handshake for the client WEBSOCKET."
274 (let ((key (generate-client-key websocket)))
275 (write-request (make-handshake-request (.uri websocket) key)
277 (let* ((response (read-response (.socket websocket)))
278 (headers (response-headers response))
279 (upgrade (assoc-ref headers 'upgrade))
280 (connection (assoc-ref headers 'connection))
281 (accept (assoc-ref headers 'sec-websocket-accept)))
282 ;; Validate the handshake.
283 (if (and (= (response-code response) 101)
284 (string-ci=? (car upgrade) "websocket")
285 (equal? connection '(upgrade))
286 (string=? (string-trim-both accept) (make-accept-key key)))
287 (set! (.state websocket) 'open)
289 (websocket-close websocket)
290 ((.on-error websocket) websocket
291 (format #f "websocket handshake failed: ~s"
292 (uri->string (.uri websocket)))))))))
294 (define (open-entropy-port)
295 "Return an open input port to a reliable source of entropy for the
297 ;; XXX: This works on GNU/Linux and OS X systems, but this isn't
299 (open-input-file "/dev/urandom"))
301 (define-method (websocket-close (websocket <websocket>))
302 "Close the WebSocket connection for the client WEBSOCKET."
303 (let ((socket (.socket websocket)))
304 (set! (.state websocket) 'closing)
305 (write-frame (make-close-frame (make-bytevector 0)) socket)
306 ;; Per section 5.5.1 , wait for the server to close the connection
307 ;; for a reasonable amount of time.
309 (match (select #() (vector socket) #() 1) ; 1 second timeout
310 ((#() #(socket) #()) ; there is output to read
311 (unless (port-eof? socket)
312 (read-frame socket) ; throw it away
315 (close-port (.entropy-port websocket))
316 (set! (.state websocket) 'closed)))