X-Git-Url: https://jxself.org/git/?p=8sync.git;a=blobdiff_plain;f=8sync%2Fsystems%2Fwebsocket%2Fserver.scm;fp=8sync%2Fsystems%2Fwebsocket%2Fserver.scm;h=080f0a5949748847541ebd255fd935f010bed09c;hp=0000000000000000000000000000000000000000;hb=955c04b12d16f4e8850766afc0bd5921f2ba1cf7;hpb=d23b593a5810b38d2517a44c09d49b2835c59e16

diff --git a/8sync/systems/websocket/server.scm b/8sync/systems/websocket/server.scm
new file mode 100644
index 0000000..080f0a5
--- /dev/null
+++ b/8sync/systems/websocket/server.scm
@@ -0,0 +1,128 @@
+;;; guile-websocket --- WebSocket client/server
+;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;;
+;;; This file is part of guile-websocket.
+;;;
+;;; Guile-websocket is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation; either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; Guile-websocket is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with guile-websocket.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; WebSocket server.
+;;
+;;; Code:
+
+(define-module (8sync systems websocket server)
+  #:use-module (ice-9 match)
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:use-module (oop goops)
+  #:use-module (8sync)
+  #:use-module (8sync ports)
+  #:use-module (8sync systems web)
+  #:use-module (8sync systems websocket frame)
+  #:use-module (8sync systems websocket utils)
+  #:export (<websocket-server>))
+
+;; See section 4.2 for explanation of the handshake.
+(define (read-handshake-request client-socket)
+  "Read HTTP request from CLIENT-SOCKET that should contain the
+headers required for a WebSocket handshake."
+  ;; See section 4.2.1.
+  (read-request client-socket))
+
+(define (make-handshake-response client-key)
+  "Return an HTTP response object for upgrading to a WebSocket
+connection for the client whose key is CLIENT-KEY, a base64 encoded
+string."
+  ;; See section 4.2.2.
+  (let ((accept-key (make-accept-key (string-trim-both client-key))))
+    (build-response #:code 101
+                    #:headers `((upgrade . ("websocket"))
+                                (connection . (upgrade))
+                                (sec-websocket-accept . ,accept-key)))))
+
+(define-actor <websocket-server> (<web-server>)
+  ((new-client websocket-client-loop))
+  (websocket-handler #:init-keyword #:websocket-handler
+                     #:getter .websocket-handler))
+
+(define (websocket-client-loop websocket-server message client)
+  "Serve client connected via CLIENT by performing the HTTP
+handshake and listening for control and data frames.  HANDLER is
+called for each complete message that is received."
+  (define (handle-data-frame type data)
+    (let* ((result   ((.websocket-handler websocket-server)
+                      (match type
+                        ('text   (utf8->string data))
+                        ('binary data))))
+           (response (cond
+                      ((string? result)
+                       (make-text-frame result))
+                      ((bytevector? result)
+                       (make-binary-frame result))
+                      ((not result)
+                       #f))))
+
+      (when response
+        (write-frame response client))))
+
+  (define (read-frame-maybe)
+    (and (not (eof-object? (lookahead-u8 client)))
+         (read-frame client)))
+
+  ;; Disable buffering for websockets
+  (setvbuf client 'none)
+
+  ;; Perform the HTTP handshake and upgrade to WebSocket protocol.
+  (let* ((request (read-handshake-request client))
+         (client-key (assoc-ref (request-headers request) 'sec-websocket-key))
+         (response (make-handshake-response client-key)))
+    (write-response response client)
+    (let loop ((fragments '())
+               (type #f))
+      (let ((frame (read-frame-maybe)))
+        (cond
+         ;; EOF - port is closed.
+         ((not frame)
+          (close-port client))
+         ;; Per section 5.4, control frames may appear interspersed
+         ;; along with a fragmented message.
+         ((close-frame? frame)
+          ;; Per section 5.5.1, echo the close frame back to the
+          ;; client before closing the socket.  The client may no
+          ;; longer be listening.
+          (false-if-exception
+           (write-frame (make-close-frame (frame-data frame)) client))
+          (close-port client))
+         ((ping-frame? frame)
+          ;; Per section 5.5.3, a pong frame must include the exact
+          ;; same data as the ping frame.
+          (write-frame (make-pong-frame (frame-data frame)) client)
+          (loop fragments type))
+         ((pong-frame? frame) ; silently ignore pongs
+          (loop fragments type))
+         ((first-fragment-frame? frame) ; begin accumulating fragments
+          (loop (list frame) (frame-type frame)))
+         ((final-fragment-frame? frame) ; concatenate all fragments
+          (handle-data-frame type (frame-concatenate (reverse fragments)))
+          (loop '() #f))
+         ((fragment-frame? frame) ; add a fragment
+          (loop (cons frame fragments) type))
+         ((data-frame? frame) ; unfragmented data frame
+          (handle-data-frame (frame-type frame) (frame-data frame))
+          (loop '() #f)))))))