1 ;;; guile-websocket --- WebSocket client/server
2 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
3 ;;; Copyright © 2017 Christopher Allan Webber <cwebber@dustycloud.org>
4 ;;; Copyright © 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 server)
29 #:use-module (ice-9 match)
30 #:use-module (rnrs bytevectors)
31 #:use-module (rnrs io ports)
32 #:use-module (web request)
33 #:use-module (web response)
34 #:use-module (web uri)
35 #:use-module (oop goops)
37 #:use-module (8sync ports)
38 #:use-module (8sync systems web)
39 #:use-module (8sync systems websocket frame)
40 #:use-module (8sync systems websocket utils)
41 #:export (<websocket-server>
44 ;; See section 4.2 for explanation of the handshake.
45 (define (read-handshake-request client-socket)
46 "Read HTTP request from CLIENT-SOCKET that should contain the
47 headers required for a WebSocket handshake."
49 (read-request client-socket))
51 (define (make-handshake-response client-key)
52 "Return an HTTP response object for upgrading to a WebSocket
53 connection for the client whose key is CLIENT-KEY, a base64 encoded
56 (let ((accept-key (make-accept-key (string-trim-both client-key))))
57 (build-response #:code 101
58 #:headers `((upgrade . ("websocket"))
59 (connection . (upgrade))
60 (sec-websocket-accept . ,accept-key)))))
62 (define no-op (const #f))
64 (define (make-simple-counter)
67 (set! count (1+ count))
70 (define-actor <websocket-server> (<web-server>)
71 ((ws-send websocket-server-send))
72 (upgrade-paths #:init-value `(("websocket" .
73 ,(wrap-apply websocket-client-loop)))
74 #:allocation #:each-subclass
75 #:accessor .upgrade-paths)
77 (gen-client-id #:init-thunk make-simple-counter)
79 ;; active websocket connections
80 (ws-clients #:init-thunk make-hash-table
81 #:accessor .ws-clients)
83 (on-ws-message #:init-keyword #:on-ws-message
84 #:getter .on-ws-message)
85 (on-ws-client-connect #:init-keyword #:on-ws-client-connect
87 #:getter .on-ws-client-connect)
88 (on-ws-client-disconnect #:init-keyword #:on-ws-client-disconnect
90 #:getter .on-ws-client-disconnect))
92 (define (web-server-gen-client-id websocket-server)
93 ((slot-ref websocket-server 'gen-client-id)))
95 (define (websocket-client-loop websocket-server client request body)
96 "Serve client connected via CLIENT by performing the HTTP
97 handshake and listening for control and data frames. HANDLER is
98 called for each complete message that is received."
99 ;; TODO: We'll also want to handle stuff like the sub-protocol.
100 (define (handle-data-frame type data)
101 ((.on-ws-message websocket-server)
102 websocket-server client-id
104 ('text (utf8->string data))
107 (define (read-frame-maybe)
108 (and (not (eof-object? (lookahead-u8 client)))
109 (read-frame client)))
111 ;; Allows other actors to send things to this specific client
112 ;; @@: We probably could just increment a counter...
113 (define client-id (web-server-gen-client-id websocket-server))
117 (hash-remove! (.ws-clients websocket-server) client-id)
118 ((.on-ws-client-disconnect websocket-server)
119 websocket-server client-id))
121 (hash-set! (.ws-clients websocket-server) client-id client)
123 ;; Disable buffering for websockets
124 (setvbuf client 'none)
126 ((.on-ws-client-connect websocket-server)
127 websocket-server client-id)
129 ;; Perform the HTTP handshake and upgrade to WebSocket protocol.
130 (let* ((client-key (assoc-ref (request-headers request) 'sec-websocket-key))
131 (response (make-handshake-response client-key)))
132 (write-response response client)
133 (let loop ((fragments '())
135 (let ((frame (read-frame-maybe)))
137 ;; EOF - port is closed.
138 ;; @@: Sometimes the eof object appears here as opposed to
139 ;; at lookahead, but I'm not sure why
140 ((or (not frame) (eof-object? frame))
142 ;; Per section 5.4, control frames may appear interspersed
143 ;; along with a fragmented message.
144 ((close-frame? frame)
145 ;; Per section 5.5.1, echo the close frame back to the
146 ;; client before closing the socket. The client may no
147 ;; longer be listening.
149 (write-frame (make-close-frame (frame-data frame)) client))
152 ;; Per section 5.5.3, a pong frame must include the exact
153 ;; same data as the ping frame.
154 (write-frame (make-pong-frame (frame-data frame)) client)
155 (loop fragments type))
156 ((pong-frame? frame) ; silently ignore pongs
157 (loop fragments type))
158 ((first-fragment-frame? frame) ; begin accumulating fragments
159 (loop (list frame) (frame-type frame)))
160 ((fragment-frame? frame) ; add a fragment
161 (loop (cons frame fragments) type))
162 ((final-fragment-frame? frame) ; concatenate all fragments
163 (handle-data-frame type (frame-concatenate (reverse fragments)))
165 ((data-frame? frame) ; unfragmented data frame
166 (handle-data-frame (frame-type frame) (frame-data frame))
169 (define (websocket-server-send websocket-server message client-id data)
170 (cond ((hash-ref (.ws-clients websocket-server) client-id) =>
173 (cond ((string? data)
174 (make-text-frame data))
176 (make-binary-frame data)))
178 ;; ok is like success, amirite
179 (<-reply message 'ok)))
181 ;; No such client with that id.
182 ;; Either it closed, or it was never there.
183 (<-reply message 'client-gone))))