8sync/systems/websocket/server.scm

   1 ;;; guile-websocket --- WebSocket client/server
   2 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
   3 ;;;
   4 ;;; This file is part of guile-websocket.
   5 ;;;
   6 ;;; Guile-websocket is free software; you can redistribute it and/or modify
   7 ;;; it under the terms of the GNU Lesser General Public License as
   8 ;;; published by the Free Software Foundation; either version 3 of the
   9 ;;; License, or (at your option) any later version.
  10 ;;;
  11 ;;; Guile-websocket is distributed in the hope that it will be useful,
  12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;; Lesser General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU Lesser General Public
  17 ;;; License along with guile-websocket.  If not, see
  18 ;;; <http://www.gnu.org/licenses/>.
  19
  20 ;;; Commentary:
  21 ;;
  22 ;; WebSocket server.
  23 ;;
  24 ;;; Code:
  25
  26 (define-module (8sync systems websocket server)
  27   #:use-module (ice-9 match)
  28   #:use-module (rnrs bytevectors)
  29   #:use-module (rnrs io ports)
  30   #:use-module (web request)
  31   #:use-module (web response)
  32   #:use-module (web uri)
  33   #:use-module (oop goops)
  34   #:use-module (8sync)
  35   #:use-module (8sync ports)
  36   #:use-module (8sync systems web)
  37   #:use-module (8sync systems websocket frame)
  38   #:use-module (8sync systems websocket utils)
  39   #:export (<websocket-server>
  40             .websocket-handler))
  41
  42 ;; See section 4.2 for explanation of the handshake.
  43 (define (read-handshake-request client-socket)
  44   "Read HTTP request from CLIENT-SOCKET that should contain the
  45 headers required for a WebSocket handshake."
  46   ;; See section 4.2.1.
  47   (read-request client-socket))
  48
  49 (define (make-handshake-response client-key)
  50   "Return an HTTP response object for upgrading to a WebSocket
  51 connection for the client whose key is CLIENT-KEY, a base64 encoded
  52 string."
  53   ;; See section 4.2.2.
  54   (let ((accept-key (make-accept-key (string-trim-both client-key))))
  55     (build-response #:code 101
  56                     #:headers `((upgrade . ("websocket"))
  57                                 (connection . (upgrade))
  58                                 (sec-websocket-accept . ,accept-key)))))
  59
  60 (define no-op (const #f))
  61
  62 (define-actor <websocket-server> (<web-server>)
  63   ((ws-send websocket-server-send))
  64   (upgrade-paths #:init-value `(("websocket" .
  65                                  ,(wrap-apply websocket-client-loop)))
  66                  #:allocation #:each-subclass
  67                  #:accessor .upgrade-paths)
  68
  69   ;; active websocket connections
  70   (ws-clients #:init-thunk make-hash-table
  71               #:accessor .ws-clients)
  72
  73   (on-ws-message #:init-keyword #:on-ws-message
  74                  #:getter .on-ws-message)
  75   (on-ws-client-connect #:init-keyword #:on-ws-client-connect
  76                         #:init-value no-op
  77                         #:getter .on-ws-client-connect)
  78   (on-ws-client-disconnect #:init-keyword #:on-ws-client-disconnect
  79                            #:init-value no-op
  80                            #:getter .on-ws-client-disconnect))
  81
  82 (define (websocket-client-loop websocket-server client request body)
  83   "Serve client connected via CLIENT by performing the HTTP
  84 handshake and listening for control and data frames.  HANDLER is
  85 called for each complete message that is received."
  86   ;; TODO: We'll also want to handle stuff like the sub-protocol.
  87   (define (handle-data-frame type data)
  88     ((.on-ws-message websocket-server)
  89      websocket-server client-id
  90      (match type
  91        ('text   (utf8->string data))
  92        ('binary data))))
  93
  94   (define (read-frame-maybe)
  95     (and (not (eof-object? (lookahead-u8 client)))
  96          (read-frame client)))
  97
  98   ;; Allows other actors to send things to this specific client
  99   ;; @@: We probably could just increment a counter...
 100   (define client-id (big-random-number))
 101
 102   (define (close-down)
 103     (close-port client)
 104     (hash-remove! (.ws-clients websocket-server) client-id)
 105     ((.on-ws-client-disconnect websocket-server)
 106      websocket-server client-id))
 107
 108   (hash-set! (.ws-clients websocket-server) client-id client)
 109
 110   ;; Disable buffering for websockets
 111   (setvbuf client 'none)
 112
 113   ((.on-ws-client-connect websocket-server)
 114    websocket-server client-id)
 115
 116   ;; Perform the HTTP handshake and upgrade to WebSocket protocol.
 117   (let* ((client-key (assoc-ref (request-headers request) 'sec-websocket-key))
 118          (response (make-handshake-response client-key)))
 119     (write-response response client)
 120     (let loop ((fragments '())
 121                (type #f))
 122       (let ((frame (read-frame-maybe)))
 123         (cond
 124          ;; EOF - port is closed.
 125          ((not frame)
 126           (close-down))
 127          ;; Per section 5.4, control frames may appear interspersed
 128          ;; along with a fragmented message.
 129          ((close-frame? frame)
 130           ;; Per section 5.5.1, echo the close frame back to the
 131           ;; client before closing the socket.  The client may no
 132           ;; longer be listening.
 133           (false-if-exception
 134            (write-frame (make-close-frame (frame-data frame)) client))
 135           (close-down))
 136          ((ping-frame? frame)
 137           ;; Per section 5.5.3, a pong frame must include the exact
 138           ;; same data as the ping frame.
 139           (write-frame (make-pong-frame (frame-data frame)) client)
 140           (loop fragments type))
 141          ((pong-frame? frame) ; silently ignore pongs
 142           (loop fragments type))
 143          ((first-fragment-frame? frame) ; begin accumulating fragments
 144           (loop (list frame) (frame-type frame)))
 145          ((final-fragment-frame? frame) ; concatenate all fragments
 146           (handle-data-frame type (frame-concatenate (reverse fragments)))
 147           (loop '() #f))
 148          ((fragment-frame? frame) ; add a fragment
 149           (loop (cons frame fragments) type))
 150          ((data-frame? frame) ; unfragmented data frame
 151           (handle-data-frame (frame-type frame) (frame-data frame))
 152           (loop '() #f)))))))
 153
 154 (define (websocket-server-send websocket-server message client-id data)
 155   (cond ((hash-ref (.ws-clients websocket-server) client-id) =>
 156          (lambda (client)
 157            (write-frame
 158             (cond ((string? data)
 159                    (make-text-frame data))
 160                   ((bytevector? data)
 161                    (make-binary-frame data)))
 162             client)
 163            ;; ok is like success, amirite
 164            (<-reply message 'ok)))
 165         (else
 166          ;; No such client with that id.
 167          ;; Either it closed, or it was never there.
 168          (<-reply message 'client-gone))))