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)))