1 ;;; guile-websocket --- WebSocket client/server
2 ;;; Copyright © 2016 David Thompson <davet@gnu.org>
4 ;;; This file is part of guile-websocket.
6 ;;; Guile-websocket is free software; you can redistribute it and/or modify
7 ;;; it under the terms of the GNU Lesser General Public License as
8 ;;; published by the Free Software Foundation; either version 3 of the
9 ;;; License, or (at your option) any later version.
11 ;;; Guile-websocket is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;; Lesser General Public License for more details.
16 ;;; You should have received a copy of the GNU Lesser General Public
17 ;;; License along with guile-websocket. If not, see
18 ;;; <http://www.gnu.org/licenses/>.
26 (define-module (8sync systems websocket client)
27 #:use-module (ice-9 match)
28 #:use-module (rnrs bytevectors)
29 #:use-module (rnrs io ports)
30 #:use-module (srfi srfi-9)
31 #:use-module (srfi srfi-9 gnu)
32 #:use-module (web request)
33 #:use-module (web response)
34 #:use-module (web uri)
35 #:use-module (8sync contrib base64)
36 #:use-module (8sync systems websocket frame)
37 #:use-module (8sync systems websocket utils)
38 #:export (make-websocket
50 ;; See Section 3 - WebSocket URIs
51 (define (encrypted-websocket-scheme? uri)
52 "Return #t if the scheme for URI is 'wss', the secure WebSocket
54 (eq? (uri-scheme uri) 'wss))
56 (define (unencrypted-websocket-scheme? uri)
57 "Return #t if the scheme for URI is 'ws', the insecure WebSocket
59 (eq? (uri-scheme uri) 'ws))
61 (define (websocket-uri? uri)
62 "Return #t if URI is a valid WebSocket URI."
63 (and (or (encrypted-websocket-scheme? uri)
64 (unencrypted-websocket-scheme? uri))
65 (not (uri-fragment uri))))
67 (define (make-client-socket uri)
68 "Connect a socket to the remote resource described by URI."
69 (let* ((port (uri-port uri))
70 (info (car (getaddrinfo (uri-host uri)
73 (symbol->string (uri-scheme uri)))
77 (s (with-fluids ((%default-port-encoding #f))
78 (socket (addrinfo:fam info) SOCK_STREAM IPPROTO_IP))))
79 ;; TODO: Configure I/O buffering?
80 (connect s (addrinfo:addr info))
83 (define-record-type <websocket>
84 (%make-websocket uri socket entropy-port state)
87 (socket websocket-socket)
88 (entropy-port websocket-entropy-port)
89 (state websocket-state set-websocket-state!))
91 (define (display-websocket ws port)
92 (format port "#<websocket ~a ~a>"
93 (uri->string (websocket-uri ws))
94 (websocket-state ws)))
96 (set-record-type-printer! <websocket> display-websocket)
98 (define (websocket-connecting? ws)
99 "Return #t if the WebSocket WS is in the connecting state."
100 (eq? (websocket-state ws) 'connecting))
102 (define (websocket-open? ws)
103 "Return #t if the WebSocket WS is in the open state."
104 (eq? (websocket-state ws) 'open))
106 (define (websocket-closing? ws)
107 "Return #t if the WebSocket WS is in the closing state."
108 (eq? (websocket-state ws) 'closing))
110 (define (websocket-closed? ws)
111 "Return #t if the WebSocket WS is in the closed state."
112 (eq? (websocket-state ws) 'closed))
114 (define (generate-client-key ws)
115 "Return a random, base64 encoded nonce using the entropy source of
118 (get-bytevector-n (websocket-entropy-port ws) 16)))
120 ;; See Section 4.1 - Client Requirements
121 (define (make-handshake-request uri key)
122 "Create an HTTP request for initiating a WebSocket connection with
123 the remote resource described by URI, using a randomly generated nonce
125 (let ((headers `((host . (,(uri-host uri) . #f))
126 (upgrade . ("WebSocket"))
127 (connection . (upgrade))
128 (sec-websocket-key . ,key)
129 (sec-websocket-version . "13"))))
130 (build-request uri #:method 'GET #:headers headers)))
132 (define (handshake ws)
133 "Perform the WebSocket handshake for the client WS."
134 (let ((key (generate-client-key ws)))
135 (write-request (make-handshake-request (websocket-uri ws) key)
136 (websocket-socket ws))
137 (let* ((response (read-response (websocket-socket ws)))
138 (headers (response-headers response))
139 (upgrade (assoc-ref headers 'upgrade))
140 (connection (assoc-ref headers 'connection))
141 (accept (assoc-ref headers 'sec-websocket-accept)))
142 ;; Validate the handshake.
143 (if (and (= (response-code response) 101)
144 (string-ci=? (car upgrade) "websocket")
145 (equal? connection '(upgrade))
146 (string=? (string-trim-both accept) (make-accept-key key)))
147 (set-websocket-state! ws 'open)
150 (error "websocket handshake failed" (websocket-uri ws)))))))
152 (define (open-entropy-port)
153 "Return an open input port to a reliable source of entropy for the
155 ;; XXX: This works on GNU/Linux and OS X systems, but this isn't
157 (open-input-file "/dev/urandom"))
159 (define (make-websocket uri-or-string)
160 "Create and establish a new WebSocket connection for the remote
161 resource described by URI-OR-STRING."
162 (let ((uri (match uri-or-string
164 ((? string? str) (string->uri str)))))
165 (if (websocket-uri? uri)
166 (let ((ws (%make-websocket uri
167 (make-client-socket uri)
172 (error "not a websocket uri" uri))))
174 (define (close-websocket ws)
175 "Close the WebSocket connection for the client WS."
176 (let ((socket (websocket-socket ws)))
177 (set-websocket-state! ws 'closing)
178 (write-frame (make-close-frame (make-bytevector 0)) socket)
179 ;; Per section 5.5.1 , wait for the server to close the connection
180 ;; for a reasonable amount of time.
182 (match (select #() (vector socket) #() 1) ; 1 second timeout
183 ((#() #(socket) #()) ; there is output to read
184 (unless (port-eof? socket)
185 (read-frame socket) ; throw it away
188 (close-port (websocket-entropy-port ws))
189 (set-websocket-state! ws 'closed)
192 (define (generate-masking-key ws)
193 "Create a new masking key using the entropy source of WS."
194 ;; Masking keys are 32 bits long.
195 (get-bytevector-n (websocket-entropy-port ws) 4))
197 (define (websocket-send ws data)
198 "Send DATA, a string or bytevector, to the server that WS is
200 ;; TODO: Send frames over some threshold in fragments.
201 (write-frame (make-text-frame data (generate-masking-key ws))
202 (websocket-socket ws)))
204 (define (websocket-receive ws)
205 "Read a response from the server that WS is connected to."
206 ;; TODO: Handle fragmented frames and control frames.
207 (let ((frame (read-frame (websocket-socket ws))))
208 (if (binary-frame? frame)
210 (text-frame->string frame))))