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 © 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 frame)
  40   #:use-module (8sync systems websocket utils)
  41   #:export (<websocket-server>
  42             .websocket-handler))
  43
  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."
  48   ;; See section 4.2.1.
  49   (read-request client-socket))
  50
  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
  54 string."
  55   ;; See section 4.2.2.
  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)))))
  61
  62 (define no-op (const #f))
  63
  64 (define (make-simple-counter)
  65   (let ((count 0))
  66     (lambda ()
  67       (set! count (1+ count))
  68       count)))
  69
  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)
  76
  77   (gen-client-id #:init-thunk make-simple-counter)
  78
  79   ;; active websocket connections
  80   (ws-clients #:init-thunk make-hash-table
  81               #:accessor .ws-clients)
  82
  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
  86                         #:init-value no-op
  87                         #:getter .on-ws-client-connect)
  88   (on-ws-client-disconnect #:init-keyword #:on-ws-client-disconnect
  89                            #:init-value no-op
  90                            #:getter .on-ws-client-disconnect))
  91
  92 (define (web-server-gen-client-id websocket-server)
  93   ((slot-ref websocket-server 'gen-client-id)))
  94
  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
 103      (match type
 104        ('text   (utf8->string data))
 105        ('binary data))))
 106
 107   (define (read-frame-maybe)
 108     (and (not (eof-object? (lookahead-u8 client)))
 109          (read-frame client)))
 110
 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))
 114
 115   (define (close-down)
 116     (close-port client)
 117     (hash-remove! (.ws-clients websocket-server) client-id)
 118     ((.on-ws-client-disconnect websocket-server)
 119      websocket-server client-id))
 120
 121   (hash-set! (.ws-clients websocket-server) client-id client)
 122
 123   ;; Disable buffering for websockets
 124   (setvbuf client 'none)
 125
 126   ((.on-ws-client-connect websocket-server)
 127    websocket-server client-id)
 128
 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 '())
 134                (type #f))
 135       (let ((frame (read-frame-maybe)))
 136         (cond
 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))
 141           (close-down))
 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.
 148           (false-if-exception
 149            (write-frame (make-close-frame (frame-data frame)) client))
 150           (close-down))
 151          ((ping-frame? frame)
 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          ((final-fragment-frame? frame) ; concatenate all fragments
 161           (handle-data-frame type (frame-concatenate
 162                                    (reverse (cons frame fragments))))
 163           (loop '() #f))
 164          ((fragment-frame? frame) ; add a fragment
 165           (loop (cons frame fragments) type))
 166          ((data-frame? frame) ; unfragmented data frame
 167           (handle-data-frame (frame-type frame) (frame-data frame))
 168           (loop '() #f)))))))
 169
 170 (define (websocket-server-send websocket-server message client-id data)
 171   (cond ((hash-ref (.ws-clients websocket-server) client-id) =>
 172          (lambda (client)
 173            (write-frame
 174             (cond ((string? data)
 175                    (make-text-frame data))
 176                   ((bytevector? data)
 177                    (make-binary-frame data)))
 178             client)
 179            ;; ok is like success, amirite
 180            (<-reply message 'ok)))
 181         (else
 182          ;; No such client with that id.
 183          ;; Either it closed, or it was never there.
 184          (<-reply message 'client-gone))))