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 ;;;
   5 ;;; This file is part of guile-websocket.
   6 ;;;
   7 ;;; Guile-websocket is free software; you can redistribute it and/or modify
   8 ;;; it under the terms of the GNU Lesser General Public License as
   9 ;;; published by the Free Software Foundation; either version 3 of the
  10 ;;; License, or (at your option) any later version.
  11 ;;;
  12 ;;; Guile-websocket is distributed in the hope that it will be useful,
  13 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 ;;; Lesser General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU Lesser General Public
  18 ;;; License along with guile-websocket.  If not, see
  19 ;;; <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22 ;;
  23 ;; WebSocket server.
  24 ;;
  25 ;;; Code:
  26
  27 (define-module (8sync systems websocket server)
  28   #:use-module (ice-9 match)
  29   #:use-module (rnrs bytevectors)
  30   #:use-module (rnrs io ports)
  31   #:use-module (web request)
  32   #:use-module (web response)
  33   #:use-module (web uri)
  34   #:use-module (oop goops)
  35   #:use-module (8sync)
  36   #:use-module (8sync ports)
  37   #:use-module (8sync systems web)
  38   #:use-module (8sync systems websocket frame)
  39   #:use-module (8sync systems websocket utils)
  40   #:use-module (fibers)
  41   #:use-module (fibers conditions)
  42   #:use-module (fibers operations)
  43   #:use-module (fibers timers)
  44   #:export (<websocket-server>
  45             .websocket-handler))
  46
  47 ;; See section 4.2 for explanation of the handshake.
  48 (define (read-handshake-request client-socket)
  49   "Read HTTP request from CLIENT-SOCKET that should contain the
  50 headers required for a WebSocket handshake."
  51   ;; See section 4.2.1.
  52   (read-request client-socket))
  53
  54 (define (make-handshake-response client-key)
  55   "Return an HTTP response object for upgrading to a WebSocket
  56 connection for the client whose key is CLIENT-KEY, a base64 encoded
  57 string."
  58   ;; See section 4.2.2.
  59   (let ((accept-key (make-accept-key (string-trim-both client-key))))
  60     (build-response #:code 101
  61                     #:headers `((upgrade . ("websocket"))
  62                                 (connection . (upgrade))
  63                                 (sec-websocket-accept . ,accept-key)))))
  64
  65 (define no-op (const #f))
  66
  67 (define (make-simple-counter)
  68   (let ((count 0))
  69     (lambda ()
  70       (set! count (1+ count))
  71       count)))
  72
  73 (define-actor <websocket-server> (<web-server>)
  74   ((ws-send websocket-server-send))
  75   (upgrade-paths #:init-value `(("websocket" .
  76                                  ,(live-wrap websocket-client-loop)))
  77                  #:allocation #:each-subclass
  78                  #:accessor .upgrade-paths)
  79
  80   (gen-client-id #:init-thunk make-simple-counter)
  81
  82   ;; active websocket connections
  83   (ws-clients #:init-thunk make-hash-table
  84               #:accessor .ws-clients)
  85
  86   (on-ws-message #:init-keyword #:on-ws-message
  87                  #:getter .on-ws-message)
  88   (on-ws-client-connect #:init-keyword #:on-ws-client-connect
  89                         #:init-value no-op
  90                         #:getter .on-ws-client-connect)
  91   (on-ws-client-disconnect #:init-keyword #:on-ws-client-disconnect
  92                            #:init-value no-op
  93                            #:getter .on-ws-client-disconnect))
  94
  95 (define (web-server-gen-client-id websocket-server)
  96   ((slot-ref websocket-server 'gen-client-id)))
  97
  98 (define (websocket-client-loop websocket-server client request body)
  99   "Serve client connected via CLIENT by performing the HTTP
 100 handshake and listening for control and data frames.  HANDLER is
 101 called for each complete message that is received."
 102   ;; TODO: We'll also want to handle stuff like the sub-protocol.
 103   (define (handle-data-frame type data)
 104     ((.on-ws-message websocket-server)
 105      websocket-server client-id
 106      (match type
 107        ('text   (utf8->string data))
 108        ('binary data))))
 109
 110   (define (read-frame-maybe)
 111     (and (not (eof-object? (lookahead-u8 client)))
 112          (read-frame client)))
 113
 114   ;; Allows other actors to send things to this specific client
 115   ;; @@: We probably could just increment a counter...
 116   (define client-id (web-server-gen-client-id websocket-server))
 117
 118   (define client-dead? (make-condition))
 119
 120   (define (close-down)
 121     (close-port client)
 122     (hash-remove! (.ws-clients websocket-server) client-id)
 123     (signal-condition! client-dead?)
 124     ((.on-ws-client-disconnect websocket-server)
 125      websocket-server client-id))
 126
 127   (hash-set! (.ws-clients websocket-server) client-id client)
 128
 129   ;; Disable buffering for websockets
 130   (setvbuf client 'none)
 131
 132   ((.on-ws-client-connect websocket-server)
 133    websocket-server client-id)
 134
 135   ;; Perform the HTTP handshake and upgrade to WebSocket protocol.
 136   (let* ((client-key (assoc-ref (request-headers request) 'sec-websocket-key))
 137          (response (make-handshake-response client-key)))
 138     (write-response response client)
 139     ;; TODO: we shoud split clients into their own objects or fibers
 140     ;; structure... what happens if we try to write at the same time
 141     ;; that we're writing another frame?
 142     ;; Probably it's good to have different fibers or methods for:
 143     ;;  - reader method/fiber
 144     ;;    - checks for client-dead? condition
 145     ;;    - may kick off some logic, which may send a message to writer
 146     ;;    - "nonblocking" reads
 147     ;;  - writer method/thread
 148     ;;    - checks for client-dead? condition
 149     ;;    - accepts one message at a time to write
 150     ;;    - "blocking" writes
 151     ;;  - ping timer method
 152     ;;    - checks for client-dead? condition
 153     ;;    - occasionally sends a message to the writer to do a ping
 154     (let* ((ws (actor-id websocket-server))
 155            (send-ping
 156             (lambda ()
 157               (<- ws 'ws-send client-id 'ping))))
 158       (spawn-fiber
 159        (lambda ()
 160          (let lp ()
 161            (and (perform-operation
 162                  (choice-operation
 163                   ;; sleep and send a ping
 164                   (wrap-operation (sleep-operation 5)
 165                                   (lambda ()
 166                                     (send-ping)
 167                                     #t)) ; loop again
 168                   ;; If the client is dead, don't loop
 169                   (wrap-operation (wait-operation client-dead?)
 170                                   (const #f))))
 171                 (lp))))))
 172
 173     (with-actor-nonblocking-ports
 174      (let loop ((fragments '())
 175                 (type #f))
 176        (let ((frame (read-frame-maybe)))
 177          (cond
 178           ;; EOF - port is closed.
 179           ;; @@: Sometimes the eof object appears here as opposed to
 180           ;;   at lookahead, but I'm not sure why
 181           ((or (not frame) (eof-object? frame))
 182            (close-down))
 183           ;; Per section 5.4, control frames may appear interspersed
 184           ;; along with a fragmented message.
 185           ((close-frame? frame)
 186            ;; Per section 5.5.1, echo the close frame back to the
 187            ;; client before closing the socket.  The client may no
 188            ;; longer be listening.
 189            (false-if-exception
 190             (write-frame (make-close-frame (frame-data frame)) client))
 191            (close-down))
 192           ((ping-frame? frame)
 193            ;; Per section 5.5.3, a pong frame must include the exact
 194            ;; same data as the ping frame.
 195            (write-frame (make-pong-frame (frame-data frame)) client)
 196            (loop fragments type))
 197           ((pong-frame? frame) ; silently ignore pongs
 198            (loop fragments type))
 199           ((first-fragment-frame? frame) ; begin accumulating fragments
 200            (loop (list frame) (frame-type frame)))
 201           ((final-fragment-frame? frame) ; concatenate all fragments
 202            (handle-data-frame type (frame-concatenate (reverse fragments)))
 203            (loop '() #f))
 204           ((fragment-frame? frame) ; add a fragment
 205            (loop (cons frame fragments) type))
 206           ((data-frame? frame) ; unfragmented data frame
 207            (handle-data-frame (frame-type frame) (frame-data frame))
 208            (loop '() #f))))))))
 209
 210 (define (websocket-server-send websocket-server message client-id data)
 211   (with-actor-nonblocking-ports
 212    (lambda ()
 213      (cond ((hash-ref (.ws-clients websocket-server) client-id) =>
 214             (lambda (client)
 215               (write-frame
 216                (cond ((string? data)
 217                       (make-text-frame data))
 218                      ((bytevector? data)
 219                       (make-binary-frame data))
 220                      ('ping
 221                       (make-ping-frame (string->utf8 "hi"))))
 222                client)
 223               ;; ok is like success, amirite
 224               'ok))
 225            ;; No such client with that id.
 226            ;; Either it closed, or it was never there.
 227            (else 'client-gone)))))