websocket: Support for sending fragmented frames.
[8sync.git] / 8sync / systems / websocket / server.scm
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 © 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 server.
25 ;;
26 ;;; Code:
27
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)
36   #:use-module (8sync)
37   #:use-module (8sync ports)
38   #:use-module (8sync systems web)
39   #:use-module (8sync systems websocket client)
40   #:use-module (8sync systems websocket frame)
41   #:use-module (8sync systems websocket utils)
42   #:export (<websocket-server>))
43
44 (define (make-handshake-response client-key)
45   "Return an HTTP response object for upgrading to a WebSocket
46 connection for the client whose key is CLIENT-KEY, a base64 encoded
47 string."
48   ;; See section 4.2.2.
49   (let ((accept-key (make-accept-key (string-trim-both client-key))))
50     (build-response #:code 101
51                     #:headers `((upgrade . ("websocket"))
52                                 (connection . (upgrade))
53                                 (sec-websocket-accept . ,accept-key)))))
54
55 (define no-op (const #f))
56
57 (define-actor <websocket-server> (<web-server>)
58   ()
59   (upgrade-paths #:init-value `(("websocket" .
60                                  ,(wrap-apply make-websocket-actor)))
61                  #:allocation #:each-subclass
62                  #:accessor .upgrade-paths)
63
64   (on-ws-connection #:init-keyword #:on-ws-connection
65                     #:init-value no-op
66                     #:getter .on-ws-connection)
67
68   (on-ws-close #:init-keyword #:on-ws-close
69                     #:init-value no-op
70                     #:getter .on-ws-close)
71   (on-ws-error #:init-keyword #:on-ws-error
72                     #:init-value no-op
73                     #:getter .on-ws-error)
74   (on-ws-message #:init-keyword #:on-ws-message
75                     #:init-value no-op
76                     #:getter .on-ws-message)
77   (on-ws-open #:init-keyword #:on-ws-open
78                     #:init-value no-op
79                     #:getter .on-ws-open))
80
81 (define (make-websocket-actor websocket-server client request body)
82   "Setup websocket actor connected via CLIENT by performing the HTTP
83 handshake."
84
85   ;; Disable buffering for websockets
86   (setvbuf client 'none)
87
88   ;; Perform the HTTP handshake and upgrade to WebSocket protocol.
89   (let* ((client-key (assoc-ref (request-headers request) 'sec-websocket-key))
90          (response (make-handshake-response client-key)))
91     (write-response response client))
92
93   (let* ((websocket-id (create-actor websocket-server <websocket>
94                                      #:socket client
95                                      #:state 'open
96                                      #:on-close (.on-ws-close websocket-server)
97                                      #:on-error (.on-ws-error websocket-server)
98                                      #:on-message (.on-ws-message websocket-server)
99                                      #:on-open (.on-ws-open websocket-server)))
100          (hive ((@@ (8sync actors) actor-hive) websocket-server))
101          (websocket ((@@ (8sync actors) hive-resolve-local-actor) hive websocket-id)))
102     ((.on-ws-connection websocket-server) websocket-id)
103     (websocket-loop websocket 'message)))