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
|
;;; guile-websocket --- WebSocket client/server
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2021 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 server.
;;
;;; Code:
(define-module (web socket server)
#:use-module (ice-9 match)
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (web request)
#:use-module (web response)
#:use-module (web uri)
#:use-module (web socket frame)
#:use-module (web socket utils)
#:export (make-server-socket
run-server))
;; See section 4.2 for explanation of the handshake.
(define (read-handshake-request client-socket)
"Read HTTP request from CLIENT-SOCKET that should contain the
headers required for a WebSocket handshake."
;; See section 4.2.1.
(read-request client-socket))
(define (make-handshake-response client-key)
"Return an HTTP response object for upgrading to a WebSocket
connection for the client whose key is CLIENT-KEY, a base64 encoded
string."
;; See section 4.2.2.
(let ((accept-key (make-accept-key (string-trim-both client-key))))
(build-response #:code 101
#:headers `((upgrade . ("websocket"))
(connection . (upgrade))
(sec-websocket-accept . ,accept-key)))))
(define* (make-server-socket #:key
(host #f)
(family AF_INET)
(addr (if host (inet-pton family host) INADDR_LOOPBACK))
(port 8080))
(let ((sock (socket PF_INET SOCK_STREAM 0)))
(setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
(bind sock AF_INET addr port)
sock))
(define (accept-new-client server-socket)
(match (accept server-socket)
((client-socket . _) client-socket)))
(define (serve-client client-socket handler)
"Serve client connected via CLIENT-SOCKET by performing the HTTP
handshake and listening for control and data frames. HANDLER is
called for each complete message that is received."
(define (handle-data-frame type data)
(let* ((result (handler (match type
('text (utf8->string data))
('binary data))))
(response (cond
((string? result)
(make-text-frame result))
((bytevector? result)
(make-binary-frame result))
((not result)
#f))))
(when response
(write-frame response client-socket))))
;; Perform the HTTP handshake and upgrade to WebSocket protocol.
(let* ((request (read-handshake-request client-socket))
(client-key (assoc-ref (request-headers request) 'sec-websocket-key))
(response (make-handshake-response client-key)))
(write-response response client-socket)
(force-output client-socket)
(let loop ()
(let ((frame (read-data-frame client-socket #:echo-close? #t)))
(when frame
(handle-data-frame (frame-type frame) (frame-data frame))
(loop))))))
(define* (run-server handler #:optional (server-socket (make-server-socket)))
"Run WebSocket server on SERVER-SOCKET. HANDLER, a procedure that
accepts a single argument, is called for each complete message that
the server receives from a client. When the message is in text
format, HANDLER is passed a string. When the message is in binary
format, HANDLER is passed a bytevector. HANDLER must return either a
string, bytevector, or #f. Strings and bytevectors are sent to the
client in response to their message, and #f indicates that nothing
should be sent back."
;; TODO: Handle multiple simultaneous clients.
(listen server-socket 1)
(sigaction SIGPIPE SIG_IGN)
(let loop ()
(serve-client (accept-new-client server-socket) handler)
(loop)))
|
