36ee4a9aae83f281daaa478eb0adcde3fe0147c6
[8sync.git] / 8sync / systems / websocket / client.scm
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>
5 ;;;
6 ;;; This file is part of guile-websocket.
7 ;;;
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.
12 ;;;
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.
17 ;;;
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/>.
21
22 ;;; Commentary:
23 ;;
24 ;; WebSocket client.
25 ;;
26 ;;; Code:
27
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)
37   #:use-module (8sync)
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)
42   #:export (<websocket>
43             .on-close
44             .on-error
45             .on-message
46             .on-open
47             .socket
48             .state
49             .url
50
51             websocket-closed?
52             websocket-closing?
53             websocket-connect
54             websocket-connecting?
55             websocket-open?
56
57             websocket-close
58             websocket-loop
59             websocket-send))
60
61 (define no-op (const #f))
62
63 (define-actor <websocket> (<actor>)
64   ((*init* websocket-init)
65    (close websocket-close)
66    (open websocket-open)
67    (send websocket-send))
68
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))
74
75   (on-close #:init-keyword #:on-close
76                  #:init-value no-op
77                  #:accessor .on-close)
78   (on-error #:init-keyword #:on-error
79             #:init-value no-op
80             #:accessor .on-error)
81   (on-message #:init-keyword #:on-message
82               #:accessor .on-message)
83   (on-open #:init-keyword #:on-open
84                 #:init-value no-op
85                 #:accessor .on-open))
86
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)))
93
94 (define-method (websocket-open (websocket <websocket>) message uri-or-string)
95   (if (websocket-closed? websocket)
96       (let ((uri (match uri-or-string
97                    ((? uri? uri) uri)
98                    ((? string? str) (string->uri str)))))
99         (if (websocket-uri? uri)
100             (catch 'system-error
101               (lambda _
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)))
107               (lambda (key . args)
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)))))
111
112 (define (subbytevector bv start end)
113   (if (= (bytevector-length bv) end) bv
114       (let* ((length (- end start))
115              (sub (make-bytevector length)))
116         (bytevector-copy! bv start sub 0 length)
117         sub)))
118
119 (define* (make-fragmented-frames data #:key (fragment-size (expt 2 15)))
120   (let ((length (if (string? data) (string-length data)
121                     (bytevector-length data))))
122     (let loop ((offset 0))
123       (let* ((size (min fragment-size (- length offset)))
124              (end (+ offset size))
125              (final? (= end length))
126              (continuation? (not (zero? offset)))
127              (frame (if (string? data) (make-text-frame (substring data offset end) #:final? final? #:continuation? continuation?)
128                         (make-binary-frame (subbytevector data offset end) #:final? final? #:continuation? continuation?))))
129         (if final? (list frame)
130             (cons frame (loop end)))))))
131
132 (define-method (websocket-send (websocket <websocket>) message data)
133   (catch #t           ; expect: wrong-type-arg (open port), system-error
134     (lambda _
135       (let* ((frames (make-fragmented-frames data)))
136         (let loop ((frames frames) (written '(nothing)))
137           (when (pair? frames)
138             (write-frame (car frames) (.socket websocket))
139             (loop (cdr frames) (cons (car frames) written))))))
140     (lambda (key . args)
141       (let ((message (format #f "~a: ~s" key args)))
142         ((.on-error websocket) websocket (format #f "send failed: ~s ~a\n" websocket message))
143         (websocket-close websocket message)))))
144
145 (define-method (websocket-init (websocket <websocket>) message)
146   (and=> (.url websocket) (cut websocket-open websocket message <>)))
147
148 (define-method (websocket-socket-open? (websocket <websocket>))
149   "Return #t if .SOCKET of WEBSOCKET is open."
150   (not (port-closed? (.socket websocket))))
151
152 (define-method (websocket-loop (websocket <websocket>) message)
153
154   (define (handle-data-frame type data)
155     ((.on-message websocket)
156      websocket
157      (match type
158        ('text   (utf8->string data))
159        ('binary data))))
160
161   (define (read-frame-maybe)
162     (and (not (eof-object? (lookahead-u8 (.socket websocket))))
163          (read-frame (.socket websocket))))
164
165   (define (close-down)
166     (websocket-close websocket message))
167
168   ((.on-open websocket) websocket)
169
170   (let loop ((fragments '())
171              (type #f))
172     (catch #t
173       (lambda _
174         (let* ((socket (.socket websocket))
175                (frame (and (websocket-open? websocket)
176                            (read-frame-maybe))))
177           (cond
178            ;; EOF - port is closed.
179            ;; @@: Sometimes the eof object appears here as opposed to
180            ;;   at lookahead, but I'm not sure why
181            ((or (not frame) (eof-object? frame))
182             (close-down))
183            ;; Per section 5.4, control frames may appear interspersed
184            ;; along with a fragmented message.
185            ((close-frame? frame)
186             ;; Per section 5.5.1, echo the close frame back to the
187             ;; socket before closing the socket.  The socket may no
188             ;; longer be listening.
189             (false-if-exception
190              (write-frame (make-close-frame (frame-data frame)) socket))
191             (close-down))
192            ((ping-frame? frame)
193             ;; Per section 5.5.3, a pong frame must include the exact
194             ;; same data as the ping frame.
195             (write-frame (make-pong-frame (frame-data frame)) socket)
196             (loop fragments type))
197            ((pong-frame? frame)         ; silently ignore pongs
198             (loop fragments type))
199            ((first-fragment-frame? frame) ; begin accumulating fragments
200             (loop (list frame) (frame-type frame)))
201            ((final-fragment-frame? frame) ; concatenate all fragments
202             (handle-data-frame type (frame-concatenate
203                                      (reverse (cons frame fragments))))
204             (loop '() #f))
205            ((fragment-frame? frame)     ; add a fragment
206             (loop (cons frame fragments) type))
207            ((data-frame? frame)         ; unfragmented data frame
208             (handle-data-frame (frame-type frame) (frame-data frame))
209             (loop '() #f)))))
210       (lambda (key . args)
211         (let ((message (format #f "~a: ~s" key args)))
212           ((.on-error websocket) websocket (format #f "read failed: ~s\n" websocket))
213           (if (websocket-socket-open? websocket) (loop '() #f)
214               (websocket-close websocket message)))))))
215
216 ;; See Section 3 - WebSocket URIs
217 (define (encrypted-websocket-scheme? uri)
218   "Return #t if the scheme for URI is 'wss', the secure WebSocket
219 scheme."
220   (eq? (uri-scheme uri) 'wss))
221
222 (define (unencrypted-websocket-scheme? uri)
223   "Return #t if the scheme for URI is 'ws', the insecure WebSocket
224 scheme."
225   (eq? (uri-scheme uri) 'ws))
226
227 (define (websocket-uri? uri)
228   "Return #t if URI is a valid WebSocket URI."
229   (and (or (encrypted-websocket-scheme? uri)
230            (unencrypted-websocket-scheme? uri))
231        (not (uri-fragment uri))))
232
233 (define (set-nonblocking! port)
234   (fcntl port F_SETFL (logior O_NONBLOCK (fcntl port F_GETFL)))
235   (setvbuf port 'block 1024))
236
237 (define (make-client-socket uri)
238   "Connect a socket to the remote resource described by URI."
239   (let* ((port (uri-port uri))
240          (info (car (getaddrinfo (uri-host uri)
241                                  (if port
242                                      (number->string port)
243                                      (symbol->string (uri-scheme uri)))
244                                  (if port
245                                      AI_NUMERICSERV
246                                      0))))
247          (sock (with-fluids ((%default-port-encoding #f))
248                  (socket (addrinfo:fam info) SOCK_STREAM IPPROTO_IP))))
249
250     (set-nonblocking! sock)
251     ;; Disable buffering for websockets
252     (setvbuf sock 'none)
253
254     ;; TODO: Configure I/O buffering?
255     (connect sock (addrinfo:addr info))
256     sock))
257
258 (define-method (write (o <websocket>) port)
259    (format port "#<websocket ~a ~a>"
260            (.url o)
261            (.state o)))
262
263 (define-method (websocket-connecting? (websocket <websocket>))
264   "Return #t if WEBSOCKET is in the connecting state."
265   (eq? (.state websocket) 'connecting))
266
267 (define-method (websocket-open? (websocket <websocket>))
268   "Return #t if WEBSOCKET is in the open state."
269   (eq? (.state websocket) 'open))
270
271 (define-method (websocket-closing? (websocket <websocket>))
272   "Return #t if WEBSOCKET is in the closing state."
273   (eq? (.state websocket) 'closing))
274
275 (define-method (websocket-closed? (websocket <websocket>))
276   "Return #t if WEBSOCKET is in the closed state."
277   (eq? (.state websocket) 'closed))
278
279 (define-method (generate-client-key (websocket <websocket>))
280   "Return a random, base64 encoded nonce using the entropy source of
281 WEBSOCKET."
282   (base64-encode
283    (get-bytevector-n (.entropy-port websocket) 16)))
284
285 ;; See Section 4.1 - Client Requirements
286 (define (make-handshake-request uri key)
287   "Create an HTTP request for initiating a WebSocket connection with
288 the remote resource described by URI, using a randomly generated nonce
289 KEY."
290   (let ((headers `((host . (,(uri-host uri) . #f))
291                    (upgrade . ("WebSocket"))
292                    (connection . (upgrade))
293                    (sec-websocket-key . ,key)
294                    (sec-websocket-version . "13"))))
295     (build-request uri #:method 'GET #:headers headers)))
296
297 (define-method (handshake (websocket <websocket>))
298   "Perform the WebSocket handshake for the client WEBSOCKET."
299   (let ((key (generate-client-key websocket)))
300     (write-request (make-handshake-request (.uri websocket) key)
301                    (.socket websocket))
302     (let* ((response (read-response (.socket websocket)))
303            (headers (response-headers response))
304            (upgrade (assoc-ref headers 'upgrade))
305            (connection (assoc-ref headers 'connection))
306            (accept (assoc-ref headers 'sec-websocket-accept)))
307       ;; Validate the handshake.
308       (if (and (= (response-code response) 101)
309                (string-ci=? (car upgrade) "websocket")
310                (equal? connection '(upgrade))
311                (string=? (string-trim-both accept) (make-accept-key key)))
312           (set! (.state websocket) 'open)
313           (begin
314             (websocket-close websocket)
315             ((.on-error websocket) websocket
316              (format #f "websocket handshake failed: ~s"
317                      (uri->string (.uri websocket)))))))))
318
319 (define (open-entropy-port)
320   "Return an open input port to a reliable source of entropy for the
321 current system."
322   (if (file-exists? "/dev/urandom")
323       (open-input-file "/dev/urandom")
324       ;; XXX: This works as a fall back but this isn't exactly a
325       ;; reliable source of entropy.
326       (make-soft-port (vector (const #f) (const #f) (const #f)
327                               (lambda _ (let ((r (random 256))) (integer->char r)))
328                               (const #f)
329                               (const #t)) "r")))
330
331 (define-method (websocket-close (websocket <websocket>))
332   "Close the WebSocket connection for the client WEBSOCKET."
333   (let ((socket (.socket websocket)))
334     (set! (.state websocket) 'closing)
335     (write-frame (make-close-frame (make-bytevector 0)) socket)
336     ;; Per section 5.5.1 , wait for the server to close the connection
337     ;; for a reasonable amount of time.
338     (let loop ()
339       (match (select #() (vector socket) #() 1) ; 1 second timeout
340         ((#() #(socket) #()) ; there is output to read
341          (unless (port-eof? socket)
342            (read-frame socket) ; throw it away
343            (loop)))))
344     (close-port socket)
345     (close-port (.entropy-port websocket))
346     (set! (.state websocket) 'closed)))